Delphi的消息处理

Delphi是Borland公司的一种面向对象的可视化软件开发工具。 Delphi集中了Visual C++和Visual Basic两者的优点:容易上手、功能强大,特别是在界面设计、数据库编程、网络编程方面更有其独特的优势。

Delphi中的消息

消息是Windows发出的一个通知,它告诉应用程序某个事件发生了。在Delphi中,大多数情况下Windows的消息被封装在VCL的事件中,我们只需处理相应的VCL事件就可以了,但如果我们需要编写自己的控件、截获或过滤消息就必须深入研究Win32的消息处理机制。

在Delphi中消息以TMessage记录的方式定义。打开Message.pas文件,我们可以看到Tmessage是这样定义的:

type

TMessage = packed record

Msg: Cardinal;

case Integer of

0: ( WParam: Longint;

LParam: Longint;

Result: Longint);

1: ( WParamLo: Word;

WParamHi: Word;

LParamLo: Word;

LParamHi: Word;

ResultLo: Word;

ResultHi: Word);

end;

其中,Msg是区别于其他消息的常量值,这些常量值可以是Windows单元中预定义的常量,也可以是用户自己定义的常量。Wparam通常是一个与消息有关的常量值,也可以是窗口或控件的句柄。LParam通常是一个指向内存中数据的指针。

Result是消息处理的返回值。Wparam、Lparam和Result都是32位的,如果想访问其中的低16位或高16位可以分别使用WparamLo、WparamHi、 LParamLo、LparamHi、ResultLo和ResultHi。

在Delphi中除了通用的Tmessage外,还为每个Windows定义了一个特殊的消息记录。我们可以浏览Message.pas文件,下面是键盘的消息记录:

TWMKey = packed record

Msg: Cardinal;

CharCode: Word;

Unused: Word;

KeyData: Longint;

Result: Longint;

与键盘相关的消息如:WM_KEYDOWN、 WM_KEYUP、 WM_CHAR、 WM_SYSKEYDOWN WM_SYSKEYUP、 WM_SYSCHAR的记录也被定义为TWMkey。在Message.pas文件中有以下声明:

TWMChar=TWMkey; TWMKeyDown=

TWMkey;TWMKeyUp=TWMkey; TWMSys

-KeyDown=TWMkey; TWMSysKeyUp=

TWMkey;TWMSysChar=TWMkey;

消息的发送

消息处理就是定义应用程序如何响应Windows的消息。在Delphi中每一个消息都有自己的处理过程,它必须是一个对象中的方法,且只能传递一个Tmessage或其他特殊的消息记录,方法声明后要有一个message命令,后接一个在0到32767之间的常量。

前面我们提到的消息都是标准的Windows消息(WM_X),除此之外还有VCL内部消息、通知消息和用户自定义消息。

VCL内部消息通常以“CM_”开头,用于管理VCL内部的事物。如果改变了某个属性值或组件的其他一些特性后,需要通过内部消息将该变化通知其他组件。例如,激活输入焦点消息是向被激活的或被停用的组件发送的,用于接受或放弃输入焦点。

另外还有通知消息,一个窗口内的子控件发生了一些事情,需要通知父窗口,这是通过通知消息实现的。它只适用于标准的窗口控件,如按钮、列表框、编辑框等等。打开Message.pas文件,在标准的Windows后就是通知消息的声明:

const

{$EXTERNALSYM BN_CLICKED}

BN_CLICKED = 0;

{$EXTERNALSYM BN_PAINT}

BN_PAINT = 1;

{$EXTERNALSYM BN_HILITE}

BN_HILITE = 2;

以上是按钮的通知消息,分别表示用户单击了按钮、按钮应当重画、用户加亮了按钮。

用户也可以自己定义消息、给自己发送消息和编写消息处理过程。消息的常量值为WM_USER+100到$7FFF, 这个范围是Windows为用户自定义消息保留的。

Delphi消息的发送有三种方法:

1.Tcontrol类的Perform对象方法。可以向任何一个窗体或控件发送消息,只需要知道窗体或控件的实例。其声明如下:

function Tcontrol.Perform(Msg:Cardinal;Wparam,Lparam:Longint):Longint

2.Windows的API函数SendMessage()和Postmessage()。其声明如下:

function SendMessage(hWnd: HWND; Msg: UINT;wParam:WPARAM; lParam: LPARAM):LRESULT;stdcall;

function SendMessage(hWnd: HWND; Msg: UINT;wParam: WPARAM; lParam:LPARAM):LRESULT;stdcall

PostMessage函数将消息添加到应用程序的消息队列中去。应用程序的消息循环会从消息队列中提取登记的该消息,再发送到相应的窗口中。

SendMessage函数可以越过消息队列直接向窗口过程发送。所以当Windows需要立刻返回值时使用SendMessage,当需要不同的应用程序依次处理消息时使用PostMessage。而Perform从本质上和SendMessage相似,它们直接向窗口过程发送。SendMessage、Postmessage函数只需要知道窗口的句柄就可以发送消息,所以它们可以向非Delphi窗体发送一条消息,但而Perform必须知道窗体或控件的实例。

VCL消息处理机制

在Delphi应用程序的源代码中有语句Application.Run,它的作用是启动消息循环,然后调用Application.ProcessMessage,该函数会在应用程序的消息队列中查找一条消息。当在消息队列中检索到一条消息后,触发Application.OnMessage事件。这样在Windows本身对消息处理之前,就会响应OnMessage事件的处理过程,它优于任何消息处理,而且只接收登记的消息,即前面所述的由PostMessage发送的消息。响应Application.OnMessage事件的处理过程必须是TmessageEvent类型,其声明如下:

type TMessageEvent = procedure (var Msg: TMsg; var Handled: Boolean) of object;

其中TMsg是Windows中定义的消息记录,我们可以这样声明:

Procedure OnMyMessage(var Msg:TMsg;var Handled:Boolean);

然后把此方法赋给Application.OnMessage事件:

Application.OnMessage :=OnMyMessage;

OnMessage事件将捕获发送给应用程序的所有消息,这是一个非常繁忙的事件,因此在处理OnMessage事件的处理过程中设置断点进行消息处理是不明智的。

VCL对象用于接收消息的方法叫MainWndProc。它是定义在Twincontrol类中的静态方法,不能被重载。它不直接处理消息,当消息离开MainWndProc后,消息被传递给对象的WndProc方法,WndProc方法是在Tcontrol类中定义的一个虚拟方法,由它调用Dispatch方法。Dispatch根据传入的Message来寻找相应的处理方法,如果最后找不到,就继续向上到父类中寻找消息处理方法,一直到找到为止,如果找不到则调用Defaulthandler。Defaulthandler方法对消息进行最后的处理,然后把消息传递给Windows的DefWindowProc函数或其他默认的窗口过程。

Posted in 软件开发 at April 18, 2006. by 傻猫 .    Views: 3386    No Comments

动态生产控件的方法和应用

一、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段说明。


 

2004-4-6 10:59:32   

 2004-4-6 11:29:16   动态创建菜单全接触

[基本认识]:
      在Delphi的程序开发环境中,封装的VCL减化了我们许多的开发工作,由在界面的设计上使开发的进度很快,但在很多的时候,我们需要自己来设计可视化的用户界面,而且是在程序的运行中,这时我们就得利用Delphi给我们提供的类来完成我们需要的工作了,下面笔者就和朋友们浅入的讨论一下动态创建"菜单"的基本知识,希望本文给那些刚入门的朋友来个抛砖引玉的作用。  
      在delphi的菜单设计中,有两个Delphi的菜单控件:
      1:Tmainmenu;
      2:Tpopupmenu;
      前者是创建窗口的菜单,后者是创建右键弹出式菜单的控件,但在Delphi庞大的类库中有一个类与这两个控件密切相关,它就是:TMenuItem,窗口的菜单和右键弹出式菜单的每个条目都是TMenuItem类的一个对象。此TMenuItem类不出现在控件板上,在程序中用代码可创建其实例。

[基本知识]:
      在tmainmenu,tpopupmenu控件中有一个属性是items,此属性是数组型,里面的参数为菜单项的索引值。
文件 编辑 查看 插入 格式 帮助
---- ---- ---- ---- ---- ----
新建 撤消 标尺 对象 字体 关于
打开 拷贝 源码 公式 颜色 
      相信您看过上面的菜单简单表示之后是非常熟悉的,在此菜单中菜单头的索引值代表如下:
      "文件"的菜单的items值为0;
      "编辑"的菜单的items值为1;以此类推。
      items属性是tmenuitem类型,而在此类型中还有一个属性,是items,如果您略懂"类"的关系,您就不难明白此类似"嵌套"的关系。"新建"菜单选项是"文件"菜单选项的子类,用代码表示为tmainmenu.items[0].items[0],"打开"菜单选项为tmainmenu.items[0].items[1],以此类推,而代表"编辑"菜单中的"拷贝"菜单选项的代码为tmainmenu.items[1].items[1],其它菜单代码表示以此类推。

[基本实例]:
      知道了菜单的items结构之后,我们就可以进一步大胆的创建自己有序的菜单了。
      上面讨论到窗口的菜单和右键弹出式菜单的每个条目都是TMenuItem类的一个对象。那么我们就可以create它的一个实例,来添加自己想要的菜单了。

[示例过程]:
1:新建一个工程。
2:添加一个tmainmenu控件。
3:添加一个button控件,并在button的onclick事件中写入如下代码:
procedure TForm1.Button1Click(Sender: TObject);
var
    files,edit:tmenuitem;{要有实例的声明}
begin
    files:=tmenuitem.Create(self);
    edit:=tmenuitem.create(self);
    files.Caption:='文件';
    edit.caption:='编辑';
    mainmenu1.AutoHotkeys:=mamanual;{此句代码为不让系统自动设置快捷键}
    form1.MainMenu1.Items.Add(files);
    form1.mainmenu1.items.add(edit);
end;  
      运行后,出现如上面例举的菜单的部分结构,如此看来动态创建菜单项的方法是非常简单的,这无疑于Delphi把系统的函数进行了封装。菜单头我们创建完了,接下来就该创建菜单里的菜单项了,由"items属性是tmenuitem类型,而在此类型中还有一个属性,是items"此句话的意思我们可以创建菜单项,代码如下:
1:新建一个工程。
2:添加一个tmainmenu控件。
3:添加一个button控件,并在button的onclick事件中写入如下代码:
procedure TForm1.Button1Click(Sender: TObject);
var
   files,edit:tmenuitem;
   new,copy:tmenuitem;
begin
   files:=tmenuitem.Create(self);
   edit:=tmenuitem.create(self);
   files.Caption:='文件';
   edit.caption:='编辑';
   mainmenu1.AutoHotkeys:=mamanual;{此句代码为不让系统自动设置快捷键}
   form1.MainMenu1.Items.Add(files);
   form1.mainmenu1.items.add(edit);
   {上部代码为创建菜单头}
   new:=tmenuitem.create(self);
   copy:=tmenuitem.create(self);
   new.Caption:='新建';
   copy.caption:='拷贝';
   files.Add(new);
   edit.add(copy);
  {上部代码为创建菜单项}
end;
      运行效果和上面菜单结构表中基本一样,但此时点击菜单项时不出现任何的事件,显然这样的软件出售量不算理想,我们可以略改代码加个事件上去。
代码如下:
1:新建一个工程。
2:添加一个tmainmenu控件。
3:
private
  procedure abc(sender:tobject);
  { Private declarations }
var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure tform1.abc(sender:tobject);
begin
   showmessage('welcome you click me!! :) xixi');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
   files,edit:tmenuitem;
   new,copy:tmenuitem;
begin
   files:=tmenuitem.Create(self);
   edit:=tmenuitem.create(self);
   files.Caption:='文件';
   edit.caption:='编辑';
   mainmenu1.AutoHotkeys:=mamanual;{此句代码为不让系统自动设置快捷键}
   form1.MainMenu1.Items.Add(files);
   form1.mainmenu1.items.add(edit);
   {上部代码为创建菜单头}
   new:=tmenuitem.create(self);
   copy:=tmenuitem.create(self);
   new.Caption:='新建';
   copy.caption:='拷贝';
   copy.onClick:=abc;
   new.onClick:=abc;
   files.Add(new);
   edit.add(copy);
   {上部代码为创建菜单项}
end;
      这时这个软件就有了交互的功能。
      有时菜单项中出现一个横的条线和出现一个子的菜单,那么这样的效果怎么用代码实现的呢,下面就是此效果的代码示例:
1:新建一个工程。
2:添加一个tmainmenu控件。
3:
procedure TForm1.Button1Click(Sender: TObject);
var
   files,edit:tmenuitem;
   new,copy:tmenuitem;
   sub1,sub2,sub3,lines:tmenuitem;
begin
   files:=tmenuitem.Create(self);
   edit:=tmenuitem.create(self);
   files.Caption:='文件';
   edit.caption:='编辑';
   mainmenu1.AutoHotkeys:=mamanual;{此句代码为不让系统自动设置快捷键}
   form1.MainMenu1.Items.Add(files);
   form1.mainmenu1.items.add(edit);
  {上部代码为创建菜单头}
   new:=tmenuitem.create(self);
   copy:=tmenuitem.create(self);
   new.Caption:='新建';
   copy.caption:='拷贝';
   files.Add(new);
   edit.add(copy);
  {上部代码为创建菜单项}
   sub1:=tmenuitem.create(self);
   sub2:=tmenuitem.create(self);
   sub3:=tmenuitem.create(self);
   lines:=tmenuitem.create(self);
   lines.caption:='-';
   sub1.caption:='子菜单1';
   sub2.caption:='子菜单2';
   sub3.caption:='子菜单3';
   new.Add(sub1);
   new.add(lines);
   new.add(sub3);
   copy.Add(sub2);
  {上面代码出现多项子菜单和横线的效果}
end;

      到此讨论的内容就要结束,菜单的创建在Delphi中是非常简单的事,在tmenuitem类中还有许多的事件和方法及属性,如Add, Clear, Click, Create, Delete, Destroy, Find, IndexOf, Insert, Remove等方法的使用都是非常简单的.

 

 2004-4-6 11:30:34   TPagecontrol TTablesheet 动态创建

动态创建TPagecontrol, TTablesheet
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;
 

 

 2004-4-6 11:32:23   动态创建控件依次显示数据库值

var
  Edit1: TEdit;
  i: integer;
begin
  table1.First;
  for i := 0 to table1.RecordCount - 1 do begin
    Edit1 := TEdit.Create(Self);
    Edit1.Parent := aForm;
    Edit1.Left := 20;
    Edit1.Top := 20 * i;
    Edit1.Text := table1.fieldbyname('姓名').asString;
    table1.next;
  end;
  edit1.Destroy;
end;

 

 2004-4-6 11:40:25   动态加减pagecontrol的页数 --- 配合《TPagecontrol TTablesheet 动态创建》使用

动态添加:
  tabsheet2:=ttabsheet.Create(self);
  tabsheet2.Caption:='fkjsd';
  tabsheet2.PageControl:=pagecontrol1;

删除:
  tabsheet1.PageControl:=nil;

 

 2004-4-6 11:43:25   快速动态创建MenuItem --- 配合《动态创建菜单全接触》使用

在设计程序时,有时我们需要动态地创建菜单, 通常我们使用以下的语句
  PopupMenu1 := TPopupMenu.Create(Self);
  Item := TMenuItem.Create(PopupMenu1);
  Item.Caption := 'First Menu';
  Item.onClick := MenuItem1Click;
  PopupMenu1.Items.Add(Item);

  Item := TMenuItem.Create(PopupMenu1);
  Item.Caption := 'Second Menu';
  Item.onClick := MenuItem2Click;
  PopupMenu1.Items.Add(Item);

  Item := TMenuItem.Create(PopupMenu1);
  Item.Caption := 'Third Menu';
  Item.onClick := MenuItem3Click;
  PopupMenu1.Items.Add(Item);

  Item := TMenuItem.Create(PopupMenu1);
  Item.Caption := '-';
  PopupMenu1.Items.Add(Item);

  Item := TMenuItem.Create(PopupMenu1);
  Item.Caption := 'Fourth Menu';
  Item.onClick := MenuItem4Click;
  PopupMenu1.Items.Add(Item);

其实我们可以使用一种更快的方法达到同样的功能, 但使用很少的代码, 那就是用NewLine和NewItem, 看看下面的例子, 是不是很简单?
PopupMenu1 := TPopupMenu.Create(Self);
with PopUpMenu1.Items do
begin
  Add(NewItem('First Menu',0,False,True,MenuItem1Click,0,'MenuItem1'));
  Add(NewItem('Second Menu',0,False,True,MenuItem2Click,0,'MenuItem2'));
  Add(NewItem('Third Menu',0,False,True,MenuItem3Click,0,'MenuItem3'));
  Add(NewLine); // 增加一个分割棒
  Add(NewItem('Fourth Menu',0,False,True,MenuItem4Click,0,'MenuItem4'));
  ...
end;

 

 2004-4-6 11:45:54   [作者:guosoong]在QuickRep上面的动态报表建立

相信每一个到这里的人,都在100多页中寻找过帮助,或多或少都会感到痛苦的,如果你看到本文之后,如果有一丝快乐,就是我最大的快乐了。
话归正题!

[项目要求]:一个字段动态建立的数据库文件(.dbf),用户要求查询打印或者把整个数据库都打印出来。

[解决方法]:
1.首先把当前Table或Query中的数据提取出来。
2.用户决定一页报表打印多少列,把提取的数据建立数据库文件。
3.建立一个QuickQep窗体,在程序运行时动态建立,并动态建立TQRDBText。
下面提供每个工作的源码。望大家修改并通知我谢谢。
1.首先把当前Table或Query中的数据提取出来。
首先定义数据库内有效数据的数据结构
type
  printvalue = record
  fidlecount: integer;  //当前数据库的行号(从0开始,完全是个人习惯)
  fidlename: string;   //字段名称
  fidlevalue: string;  //字段内容
  end;
pNowPrintvalue = ^printvalue;  //定义指针
这个结构大家可以随意修改

//这个命令是TTable的,用于把一个数据库文件全部提取出来  TQuery就留给大家自己做吧
procedure TForm1.CreateQRTlistByTTable(filename: string; ValueTlist: Tlist);
var
  temppoint: pNowPrintvalue;
  tempTStrings: Tstrings;
  temploop1,temploop2: integer;
  temptable: TTable;
  tempTString: Tstrings;
begin
  if filename = '' then exit;
  if ValueTlist = nil then ValueTlist := Tlist.Create;
  ValueTlist.Clear;
  temptable := TTable.Create(nil);
  tempTStrings := Tstringlist.Create;
  try
    if sysutils.FileExists(filename) then
    begin
      temptable.Close;
      temptable.DatabaseName := sysutils.ExtractFilePath(filename);
      temptable.TableName := sysutils.ExtractFileName(filename);
      temptable.Open;

      temptable.First;
      tempTStrings := temptable.FieldList;
      if tempTStrings.Count <= 0 then exit;
      for temploop2 := 0 to temptable.RecordCount -1 do
      begin
        for temploop1 := 0 to tempTStrings.Count -1 do
        begin
          if tempTStrings[temploop1] <> '' then
          begin
            new(temppoint);
            temppoint.fidlecount := temploop2;
            temppoint.fidlename := tempTStrings[temploop1];
            if temptable.FieldValues[tempTStrings[temploop1]] = null then
            temppoint.fidlevalue := ' '
            else
            temppoint.fidlevalue := temptable.FieldValues[tempTStrings[temploop1]];
            ValueTlist.Add(temppoint);
          end;
        end;
        temptable.Next;
      end;
    end;
  finally
    temptable.Free;
  end;
end;

//上面程序里的TLIST就是下面函数的需要的ValueTlist
//QRCOLcount 就是用户决定一页打印的列数

function TForm1.WriteQRTempDBF(ValueTlist: Tlist;
  QRCOLcount: integer): integer;
var
  templist: Tlist;
  tempint: integer;
  temptable: TTable;
  temploop1,temploop2,temploop3: integer;
  temppoint: pNowPrintvalue;
  tempvalue: array of string;
  modint,endint:integer;
const
  tempdbname = 'temprint.DBF';
  FieldNames = 'TEMPFD';
begin
  result := 0;
  if QRCOLcount <= 0 then exit;
  if ValueTlist = nil then exit;
  if ValueTlist.Count <= 0 then exit;
  temploop3 := QRCOLcount;
  temploop1 := QRCOLcount;
  temploop2 := ValueTlist.Count div temploop3;

 if ValueTlist.Count mod temploop3 <> 0 then
  begin
    temploop2 := temploop2 +1;
    modint := ValueTlist.Count mod temploop3;
  end;

  endint := temploop2;
  templist := Tlist.Create;
  temptable := TTable.Create(nil);
  try
    tempint := CreateTempQRFieldList(QRCOLcount,templist); //这里是建立有效数据的数据库文件的命令
    if tempint >0 then
    begin
     tempint := CreateDatebases(temptable,BDEName,tempdbname,ttDBase,templist,false);//这里是建立空数据库的命令
     if tempint >0 then
     begin
       temptable.Close;
       temptable.DatabaseName := BDEName;  //这里是一个全局的数据库别名,大家可以自己定义
       temptable.TableName := tempdbname;
       temptable.Open;//下面就是把带入的有效数据,填入数据库的工作
       with temptable do
       begin
         Append;
         for temploop2 := 0 to temploop2-1 do
         begin
           if (temploop2 <> endint-1) then
           begin
           Insert;
           tempvalue := nil;
           setlength(tempvalue,QRCOLcount);
           for temploop3 := 0 to temploop3-1 do
           begin
             temppoint := ValueTlist.Items[temploop2*QRCOLcount+temploop3];

             FieldByName(FieldNames+inttostr(temploop3)).AsString :=temppoint.fidlename;
             tempvalue[temploop3] := temppoint.fidlevalue;


             if temploop3 = QRCOLcount-1 then
             begin
               Post;
               inc(result);
               Insert;
               for temploop1 := 0 to temploop1-1 do
               FieldByName(FieldNames+inttostr(temploop1)).AsString :=tempvalue[temploop1];
               Post;
               inc(result);
             end;

           end;
           end
           else
           begin
             if (modint > 0) then
             begin
             Insert;
             tempvalue := nil;
             setlength(tempvalue,modint);
             for temploop3 := 0 to modint-1 do
             begin
               temppoint := ValueTlist.Items[temploop2*QRCOLcount+temploop3];

               FieldByName(FieldNames+inttostr(temploop3)).AsString :=temppoint.fidlename;
               tempvalue[temploop3] := temppoint.fidlevalue;


               if temploop3 = modint-1 then
               begin
                 Post;
                 inc(result);
                 Insert;
                 for temploop1 := 0 to modint-1 do
                 FieldByName(FieldNames+inttostr(temploop1)).AsString :=tempvalue[temploop1];
                 Post;
                 inc(result);
               end;
             end;
             end
             else
             begin
               Insert;
               tempvalue := nil;
               setlength(tempvalue,QRCOLcount);
               for temploop3 := 0 to temploop3-1 do
               begin
                 temppoint := ValueTlist.Items[temploop2*QRCOLcount+temploop3];

                 FieldByName(FieldNames+inttostr(temploop3)).AsString :=temppoint.fidlename;
                 tempvalue[temploop3] := temppoint.fidlevalue;


                 if temploop3 = QRCOLcount-1 then
                 begin
                   Post;
                   inc(result);
                   Insert;
                   for temploop1 := 0 to temploop1-1 do
                   FieldByName(FieldNames+inttostr(temploop1)).AsString :=tempvalue[temploop1];
                   Post;
                   inc(result);
                 end;

               end;
             end;

           end;

         end;  //for temploop2 := 0 to temploop2-1 do

       end;
     end;
    end;
  finally
    templist.Free;
    temptable.Free;
  end;
end;

//接着就是动态建立TQRDBTEXT控件
//SenderParent: TGSQuickReport  只是一个普通的TQuickRep
//TGSQuickReport = class(TQuickRep) 只是程序建立时不要让它自动建立
//Cols是用户定义的列数
procedure TForm1.FormatQRFormWithDataset(NowDataset: TDataset; Cols: integer; SenderParent: TGSQuickReport);
var
  tempqredit: TQRDBText;
  temploop1: integer;

  nowtop,nowleft: integer; //当前的起点
  nowDetailWidth: extended;
  everylabwidth:extended;  //每个Lable的宽度和高度
  nowcol: integer;
const
  FieldNames = 'tempfd';
begin
  if SenderParent = nil then exit;
  nowcol := Cols;
  nowtop := 0;
  nowleft := 0;
  nowDetailWidth := trunc(SenderParent.DetailBand1.Size.Width);

  everylabwidth := trunc(nowDetailWidth / nowcol);
  for temploop1 := 0 to nowcol -1 do
  begin
    tempqredit := TQRDBText.Create(self);
    tempqredit.AutoSize := false;
    tempqredit.AutoStretch := false;
    tempqredit.Color := clskyblue;//clmoneygreen
    tempqredit.Parent := SenderParent.DetailBand1;
    tempqredit.Top := nowtop;
    tempqredit.Left := nowleft;
    tempqredit.Size.Width := everylabwidth;
    tempqredit.DataSet := NowDataset;
    tempqredit.DataField := FieldNames + inttostr(temploop1);

    nowleft:= nowleft + tempqredit.Width;
  end;
end;


//当以上三个步骤作完之后就基本成功了
下面一个是一个Button下的命令过程
procedure TForm1.BitBtn11Click(Sender: TObject);
var
  temptlist: Tlist;
  tempcount: integer;
  temppoint: pNowPrintvalue;
  tempQR: TGSQuickReport;
  temptable: TTable;
const
  tempdbname = 'temprint.DBF';
begin
  temptlist := Tlist.Create;
  temptable := TTable.Create(nil);
  tempQR := TGSQuickReport.Create(nil);
  try
    self.OpenDialog1.InitialDir := projectpath;
    self.OpenDialog1.Title := '';
    self.OpenDialog1.Filter := '';
    if self.OpenDialog1.Execute then
    begin
      CreateQRTlistByTTable(self.OpenDialog1.FileName,temptlist);
      if temptlist.Count <= 0 then exit;
      tempcount := WriteQRTempDBF(temptlist,4);
      if tempcount > 0 then
      begin
        temptable.Close;
        temptable.DatabaseName := BDEName;
        temptable.TableName := tempdbname;
        temptable.Open;
        tempQR.DataSet := temptable;
        FormatQRFormWithDataset(temptable,4,tempQR);
      end;
      tempQR.PreviewModal;
    end;
  finally
    temptable.Close;
    temptable.Free;
    temptlist.Free;
  end;
end;


//这里再补充两个函数,一个是建立数据库字段信息的函数,一个是动态建立数据库的函数
Function CreateTempQRFieldList(cols: integer;var resultlist: Tlist): integer; //建立打印数据库文件列表
var
  FieldNames: array of string;
  FieldDatas: pFieldDatas;
  Temploop: integer;
const
  FieldSize = 40;
  FieldType = ftString;
  tempfieldname = 'tempfd';
begin
  resultlist.Clear;
  result := 0;
  if cols <= 0 then exit;
  setlength(FieldNames,cols);
  for Temploop := 0 to cols-1 do
  begin
    New(FieldDatas);
    FieldDatas.DataFieldName := tempfieldname + inttostr(temploop);
    FieldDatas.DataFieldType := FieldType;
    FieldDatas.DataFieldSize := FieldSize;
    resultList.Add(FieldDatas);
  end;
  result := resultList.Count;

end;


Function CreateDatebases ( Tabless : TTable; //table控件名
                            DBNames : string;  //数据库别名
                            TNames : string;   //数据库名
                            TTypes : TTableType; //数据库类型
                            CreateDBFList: Tlist;    //数据库内容的列表
                            CreateIt: boolean): integer;
var
  TempDatas: pFieldDatas;
  TempCounts: integer;
begin
  result := 0;
  TempCounts := CreateDBFList.Count;
  if TempCounts <= 0 then exit;
  Tabless.Close;
  with Tabless do
  begin
     DatabaseName := DBNames;
     TableName := TNames;
     TableType := TTypes;

       with FieldDefs do
       begin
         //if Createit then Clear;
         clear;
         for TempCounts := 0 to TempCounts - 1 do
         begin
         TempDatas := CreateDBFList.Items[TempCounts];
         Add(TempDatas.DataFieldName,TempDatas.DataFieldType,TempDatas.DataFieldSize,false);
         inc(result);
         end;
       end;
     CreateTable;
  end;
  Tabless.Close;
end;


此前已经有转载。感谢作者提供学习的资料。

 

 2004-4-6 11:48:29   如何根据名字来动态创建对象

[问题的提出]:
    我希望根据一个字符串,来创建该类的对象,例如我给定'TButton',那么能在运行的时候,动态创建Button出来?不要告诉我用if来判断或者用case来判断等等~,那样的话,有几百个控件的话,岂不是晕倒?

[解决方案]:
    请参考下面的代码,下面的代码演示了三种控件的动态创建,若需要动态创建其他的,请修改那个数组常量即可:

function DynCreateControlByName(AClassName: string; AOwner: TWinControl = nil): TControl;

const
/// You can add any class if you want!
  ControlClass : array[0..2] of TPersistentClass = (TButton, TEdit, TLabel);

var
  Cls : TControlClass;

begin
  Result := nil;
  RegisterClasses(ControlClass);
  Cls := TControlClass(GetClass(AClassName));
  if Cls = nil then exit;
    Result := Cls.Create(AOwner);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Control : TControl;
begin
  Control := DynCreateControlByName(Edit1.Text);
  if Control <> nil then
    with Control do
    begin
      Parent := Self;
      Left := Random(Self.Width) - Width;
      Top := Random(Self.Width) - Height;
      Perform(WM_SETTEXT,Length(Edit1.Text),integer(pchar(Edit1.Text)));
      Show;
    end;
end;
---------------------------------------

procedure TForm1.Button2Click(Sender: TObject);
begin
  TWinControlClass(FindClass('TQRDBText')).Create(Self);
end;

initialization

RegisterClasses([TQRDBText]);

finalization
  UnregisterClasses([TQRDBText]);
end.

Posted in 软件开发 at April 18, 2006. by 傻猫 .    Views: 5742    2 Comments

delphi 7的TSeverSocket和TClientSocket组见哪里去了

Borland is deprecating the use of the TServerSocket
    and TClientSocket from the unit ScktComp. It is
    recommended that you use the Indy components for
    socket operations. The TServerSocket and
    TClientSocket will no longer be installed on the
    component palette by default. If you require the
    use of these components then you can install
    the design time package named dclsockets70.bpl,
    found in your bin directory. For deployment with
    runtime packages, you will need to deploy rtl70.bpl
    and any other required packages
偶简单翻译了一下:TClientSocket 本来是D5默认安装的,但是D7使用的Indy组件后,就没有默认安装了,如果你喜欢这个组件,可以在D7的安装目录bin文件夹找到dclsockets70.bpl组件包,安装上去就OK了.rtl70.bpl是TCientSocket和TServerSocket必需的运行包. 

Posted in 软件开发 at April 18, 2006. by 傻猫 .    Views: 4702    No Comments

最简单的方法操作ini文件

procedure TFmMain.N3Click(Sender: TObject);
var
  filename:string;
begin
  filename:=ExtractFilePath(paramstr(0))+'dbconf.ini';
  myinifile:=Tinifile.Create(filename);
  ADOConnection1.Close;
  EditConnectionString(ADOConnection1);
  myinifile.WriteString('dbconf','connectstring',adoconnection1.ConnectionString);
  myinifile.Free;
end;

Posted in 软件开发 at April 18, 2006. by 傻猫 .    Views: 5225    2 Comments