Components – 蓝天白云

Delphi中使用ISuperObject解析Json数据

分类：Components, Delphi, Other 阅读 (9,269) No Responses »

7月 102016

　　Java、Php等语言中都有成熟的框架来解析Json数据，可以让我们使用很少的代码就把格式化好的json数据转换成程序可识别的对象或者属性，同时delphi中也有这样的组件来实现此功能，即IsuperObject。如果还没有这个组件的请在网上搜索下载或者在下面留言处留下你的邮箱向本人索取。

　　下面先说一下ISuperObject中几个常用的函数

function SO(const s: SOString = ‘{}’): ISuperObject; overload; 此函数传入json数据字符串，并返回一个ISuperObject对象，这一般是我们解析json时使用的第一个函数，如jObj := SO(jsonstr)。
property O[const path: SOString]: ISuperObject read GetO write PutO; default; 如：jobj.O[‘username’]，此函数被一个ISuperObject对象调用，方括号内的字符串为json中的字段名称，返回一个ISuperObject对象。
property S[const path: SOString]: SOString read GetS write PutS; 此函数被一个ISuperObject对象调用，和O[‘username’]不同的是，它返回的是一个SoString，即一个字符串，使用方法 str := jObj.S[‘username’]; 同理的还有其他几个类似的函数，如I[‘age’]返回整数，B[‘isenable’]返回布尔型，A[‘users’]返回一个TSuperArray数组
AsString, AsBoolean, AsInteger,AsArray，ISuperObject的函数，用来把ISuperObject转换成相应的数据类型。

　　下面我们看一个演示代码，json数据如下

{
    "retcode": "1", 
    "datafrom": "server",
    "users": "[{\"id\":1, \"username\": \"liuderu\", \"website\": \"bcoder.com\"},{\"id\":2, \"username\": \"Jeoe\", \"website\": \"baidu.com\"}]"
}

{

"retcode": "1",

"datafrom": "server",

"users": "[{\"id\":1, \"username\": \"liuderu\", \"website\": \"bcoder.com\"},{\"id\":2, \"username\": \"Jeoe\", \"website\": \"baidu.com\"}]"

}

　　Delphi版本2010，代码如下：

unit uFmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Buttons, superobject;

type
  TFmMain = class(TForm)
    Memo1: TMemo;
    ListView1: TListView;
    BitBtn1: TBitBtn;
    Label1: TLabel;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FmMain: TFmMain;

implementation

{$R *.dfm}

procedure TFmMain.BitBtn1Click(Sender: TObject);
var
  jRet, jUsers: ISuperObject;
  aryUsers: TSuperArray;
  retCode: integer;
  strUsers: string;
  i: integer;
begin
  jRet := SO(Memo1.Text);
  if (jRet.O['retcode'] <> nil) then begin
    retCode := jRet.O['retcode'].AsInteger;
    Label1.Caption := '返回值：' + IntToStr(retCode) + ';  数据来源：' + jRet.O['datafrom'].AsString;

    if(jRet.O['retcode'].AsInteger = 1) then begin
      strUsers := jRet.O['users'].AsString;
      jUsers := SO(strUsers);
      aryUsers := jUsers.AsArray;
      for I := 0 to aryUsers.Length - 1 do begin
        with  ListView1.Items.Add do begin
          Caption := aryUsers[i].O['id'].AsString;
          SubItems.Add(aryUsers[i].O['username'].AsString);
          SubItems.Add(aryUsers[i].O['website'].AsString);
        end;
      end;
    end;
  end;
end;

end.

unit uFmMain;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls, Buttons, superobject;

type

TFmMain = class(TForm)

Memo1: TMemo;

ListView1: TListView;

BitBtn1: TBitBtn;

Label1: TLabel;

procedure BitBtn1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

FmMain: TFmMain;

implementation

{$R *.dfm}

procedure TFmMain.BitBtn1Click(Sender: TObject);

var

jRet, jUsers: ISuperObject;

aryUsers: TSuperArray;

retCode: integer;

strUsers: string;

i: integer;

begin

jRet := SO(Memo1.Text);

if (jRet.O['retcode'] <> nil) then begin

retCode := jRet.O['retcode'].AsInteger;

Label1.Caption := '返回值：' + IntToStr(retCode) + '; 数据来源：' + jRet.O['datafrom'].AsString;

if(jRet.O['retcode'].AsInteger = 1) then begin

strUsers := jRet.O['users'].AsString;

jUsers := SO(strUsers);

aryUsers := jUsers.AsArray;

for I := 0 to aryUsers.Length - 1 do begin

with ListView1.Items.Add do begin

Caption := aryUsers[i].O['id'].AsString;

SubItems.Add(aryUsers[i].O['username'].AsString);

SubItems.Add(aryUsers[i].O['website'].AsString);

end;

end.

点击下载源代码

Delphi操作RichEdit总结

分类：Components, Delphi 阅读 (10,769) No Responses »

2月 102015

uses RichEdit;

1. 设置RichEdit的行间距，代码如下

procedure TForm1.Button3Click(Sender: TObject);
var
  pf: PARAFORMAT2;
begin
  FillChar(pf, sizeof(paraformat2), #0);
  pf.cbSize := SizeOf(paraformat2);
  pf.dwMask := PFM_LINESPACING  ;   //需要设置上 PFM_LINESPACING 标志，bLineSpacingRule和dyLineSpacing才可能有效

//  pf.bLineSpacingRule := 0;   //单倍行距，dyLineSpacing的值将被忽略
//  pf.bLineSpacingRule := 1;   //1.5倍行距，dyLineSpacing的值将被忽略
//  pf.bLineSpacingRule := 2;   //两倍行距，dyLineSpacing的值将被忽略
//  pf.bLineSpacingRule := 3;   //用dyLineSpacing以缇为单位指定行间距，当此值小于单倍行距时，效果为单倍行距
//  pf.bLineSpacingRule := 5;   //用dyLineSpacing/20指定行间距

  pf.bLineSpacingRule := 4;   //用dyLineSpacing以缇为单位指定行间距
  pf.dyLineSpacing := RichEdit1.Font.Size * 20 + 20 * 4; //这是笔者大概计算的，可以根据字体大小调节的，行间最小距离，大字体时可能出现上下行重叠，可以设置为300或者自己计算

  RichEdit1.SelectAll;   //只对选择的文本有效，***重要***
  SendMessage(RichEdit1.Handle, EM_SETPARAFORMAT, 0, LPARAM(@pf));
  RichEdit1.SelStart := 0;
  RichEdit1.SelLength := 0;
end;

procedure TForm1.Button3Click(Sender: TObject);

var

pf: PARAFORMAT2;

begin

FillChar(pf, sizeof(paraformat2), #0);

pf.cbSize := SizeOf(paraformat2);

pf.dwMask := PFM_LINESPACING ; //需要设置上 PFM_LINESPACING 标志，bLineSpacingRule和dyLineSpacing才可能有效

// pf.bLineSpacingRule := 0; //单倍行距，dyLineSpacing的值将被忽略

// pf.bLineSpacingRule := 1; //1.5倍行距，dyLineSpacing的值将被忽略

// pf.bLineSpacingRule := 2; //两倍行距，dyLineSpacing的值将被忽略

// pf.bLineSpacingRule := 3; //用dyLineSpacing以缇为单位指定行间距，当此值小于单倍行距时，效果为单倍行距

// pf.bLineSpacingRule := 5; //用dyLineSpacing/20指定行间距

pf.bLineSpacingRule := 4; //用dyLineSpacing以缇为单位指定行间距

pf.dyLineSpacing := RichEdit1.Font.Size * 20 + 20 * 4; //这是笔者大概计算的，可以根据字体大小调节的，行间最小距离，大字体时可能出现上下行重叠，可以设置为300或者自己计算

RichEdit1.SelectAll; //只对选择的文本有效，***重要***

SendMessage(RichEdit1.Handle, EM_SETPARAFORMAT, 0, LPARAM(@pf));

RichEdit1.SelStart := 0;

RichEdit1.SelLength := 0;

end;

2. 为RichEdit设置行号，代码如下：

procedure TForm1.Button4Click(Sender: TObject);
const
  PFNS_PAREN	=	$000;  //e.g. 1)
  PFNS_PARENS	= $100;  //e.g. (1)
  PFNS_PERIOD	= $200;  //e.g. 1.
  PFNS_PLAIN	=	$300;
  PFNS_NONUMBER =	$400;

const
  PFN_NONE     = $00000000;  //无
  PFN_BULLET   = $00000001;  //黑色实心圆点
  PFN_ARABIC   = $00000002;  //0,1,2
  PFN_LCLETTER = $00000003;  //a,b,c
  PFN_UCLETTER = $00000004;  //A,B,C
  PFN_LCROMAN  = $00000005;  //i,ii,iii
  PFN_UCROMAN  = $00000006;  //I,II,III

  var
  pf: PARAFORMAT2;
begin
  FillChar(pf, sizeof(paraformat2), #0);
  pf.cbSize := SizeOf(paraformat2);
  //PFM_NUMBERING: wNumbering 值有效
  //PFM_NUMBERINGSTYLE: wNumberingStyle值有效
  //PFM_NUMBERINGSTART: wNumberingStart值有效
  //PFM_STARTINDENT: dxStartIndent值有效
  pf.dwMask := PFM_NUMBERING or PFM_NUMBERINGSTYLE or PFM_NUMBERINGSTART or PFM_STARTINDENT;//or PFM_OFFSET;

  pf.wNumberingStyle := PFNS_PERIOD;  //设置行号的样式，可以为“)”，“.”，“()”
  pf.wNumberingStart := 1;            //设置行号起始值
  pf.wNumbering := PFN_ARABIC;        //设置行号的格式，可以为阿拉伯数字或者英文字母等格式
  pf.dxStartIndent := 60;             //设置行首缩进值

  RichEdit1.SelectAll;
  SendMessage(RichEdit1.Handle, EM_SETPARAFORMAT, 0, LPARAM(@pf));
  RichEdit1.SelStart := 0;
  RichEdit1.SelLength := 0;
end;

procedure TForm1.Button4Click(Sender: TObject);

const

PFNS_PAREN = $000; //e.g. 1)

PFNS_PARENS = $100; //e.g. (1)

PFNS_PERIOD = $200; //e.g. 1.

PFNS_PLAIN = $300;

PFNS_NONUMBER = $400;

const

PFN_NONE = $00000000; //无

PFN_BULLET = $00000001; //黑色实心圆点

PFN_ARABIC = $00000002; //0,1,2

PFN_LCLETTER = $00000003; //a,b,c

PFN_UCLETTER = $00000004; //A,B,C

PFN_LCROMAN = $00000005; //i,ii,iii

PFN_UCROMAN = $00000006; //I,II,III

var

pf: PARAFORMAT2;

begin

FillChar(pf, sizeof(paraformat2), #0);

pf.cbSize := SizeOf(paraformat2);

//PFM_NUMBERING: wNumbering 值有效

//PFM_NUMBERINGSTYLE: wNumberingStyle值有效

//PFM_NUMBERINGSTART: wNumberingStart值有效

//PFM_STARTINDENT: dxStartIndent值有效

pf.dwMask := PFM_NUMBERING or PFM_NUMBERINGSTYLE or PFM_NUMBERINGSTART or PFM_STARTINDENT;//or PFM_OFFSET;

pf.wNumberingStyle := PFNS_PERIOD; //设置行号的样式，可以为“)”，“.”，“()”

pf.wNumberingStart := 1; //设置行号起始值

pf.wNumbering := PFN_ARABIC; //设置行号的格式，可以为阿拉伯数字或者英文字母等格式

pf.dxStartIndent := 60; //设置行首缩进值

RichEdit1.SelectAll;

SendMessage(RichEdit1.Handle, EM_SETPARAFORMAT, 0, LPARAM(@pf));

RichEdit1.SelStart := 0;

RichEdit1.SelLength := 0;

end;

3. 根据鼠标位置定位光标的方法。

当RichEdit为可用状态时，是不用代码控制此操作的，TRichEdit本身就可以定位光标。但是当RichEdit开始不可用时，则此方法就可能用到了。本例中RichEdit1开始时是不可用的，当在ApplicationEvents1中接收到RichEdit1被双击时则设置RichEdit1的Enable := true;并且定位光标。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, RichEdit, AppEvnts;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    ApplicationEvents1: TApplicationEvents;
    procedure EnableRichEdit;
    procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  FLastMousePos: TPoint;

implementation

{$R *.dfm}

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var
  mPos: TPoint;
begin
  if msg.message = WM_LBUTTONDBLCLK then begin
    if msg.hwnd = RichEdit1.Parent.Handle then begin
      GetCursorPos(FLastMousePos);
      EnableRichEdit;
    end;
  end ;
end;

procedure TForm1.EnableRichEdit;
var
  cPos: TPoint;
  retCode: integer;
  mR, mC: Word;
begin
  RichEdit1.Enabled := True;
  RichEdit1.SetFocus ;
  RichEdit1.SelStart := 0;

  if (FLastMousePos.X = 0) and (FLastMousePos.Y = 0) then
    GetCursorPos(FLastMousePos);
  FLastMousePos := RichEdit1.ScreenToClient(FLastMousePos);
  retCode := SendMessage(RichEdit1.Handle, EM_CHARFROMPOS, 0, LPARAM(@FLastMousePos));
  mR := HiWord(retCode);
  mC := Loword(retCode);
  cPos.X := mC ;
  cPos.Y := mR ;
  RichEdit1.CaretPos := cPos;

  FLastMousePos.X := 0;
  FLastMousePos.Y := 0;
end;

end.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls, RichEdit, AppEvnts;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

ApplicationEvents1: TApplicationEvents;

procedure EnableRichEdit;

procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

FLastMousePos: TPoint;

implementation

{$R *.dfm}

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;

var Handled: Boolean);

var

mPos: TPoint;

begin

if msg.message = WM_LBUTTONDBLCLK then begin

if msg.hwnd = RichEdit1.Parent.Handle then begin

GetCursorPos(FLastMousePos);

EnableRichEdit;

end;

end ;

end;

procedure TForm1.EnableRichEdit;

var

cPos: TPoint;

retCode: integer;

mR, mC: Word;

begin

RichEdit1.Enabled := True;

RichEdit1.SetFocus ;

RichEdit1.SelStart := 0;

if (FLastMousePos.X = 0) and (FLastMousePos.Y = 0) then

GetCursorPos(FLastMousePos);

FLastMousePos := RichEdit1.ScreenToClient(FLastMousePos);

retCode := SendMessage(RichEdit1.Handle, EM_CHARFROMPOS, 0, LPARAM(@FLastMousePos));

mR := HiWord(retCode);

mC := Loword(retCode);

cPos.X := mC ;

cPos.Y := mR ;

RichEdit1.CaretPos := cPos;

FLastMousePos.X := 0;

FLastMousePos.Y := 0;

end;

end.

4. 使Richedit中的链接可以点击

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, RichEdit, ShellAPI;

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure WndProc(var Msg: TMessage); override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  mask: Word;
begin
  mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);
  SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);
end;

procedure TForm1.WndProc(var Msg: TMessage);
var
  p: TENLink;
  sURL: string;
  CE : TRichEdit;
begin
  if (Msg.Msg = WM_NOTIFY) then
  begin
    if (PNMHDR(Msg.lParam).code = EN_LINK) then
    begin
      p := TENLink(Pointer(TWMNotify(Msg).NMHdr)^);
      if (p.Msg = WM_LBUTTONDOWN) then
      begin
        try
          CE := tRichEdit(Self.ActiveControl);
          SendMessage(CE.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));
          sURL := CE.SelText;
          ShellExecute(0, 'open', PChar(sURL), 0, 0, SW_SHOWNORMAL);
        except
        end;
      end;
    end;
  end;
  inherited;
end;

end.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls, ComCtrls, RichEdit, ShellAPI;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

procedure WndProc(var Msg: TMessage); override;

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

var

mask: Word;

begin

mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);

SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, mask or ENM_LINK);

SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, Integer(True), 0);

end;

procedure TForm1.WndProc(var Msg: TMessage);

var

p: TENLink;

sURL: string;

CE : TRichEdit;

begin

if (Msg.Msg = WM_NOTIFY) then

begin

if (PNMHDR(Msg.lParam).code = EN_LINK) then

begin

p := TENLink(Pointer(TWMNotify(Msg).NMHdr)^);

if (p.Msg = WM_LBUTTONDOWN) then

begin

try

CE := tRichEdit(Self.ActiveControl);

SendMessage(CE.Handle, EM_EXSETSEL, 0, Longint(@(p.chrg)));

sURL := CE.SelText;

ShellExecute(0, 'open', PChar(sURL), 0, 0, SW_SHOWNORMAL);

except

end;

inherited;

end;

end.

Delphi中如何判断是否有程序全屏

分类：Components, Delphi, System 阅读 (3,030) No Responses »

12月 312014

方法一：

　　定时调用GetForegroundWindow获取最前端的窗口句柄，然后判断该窗口宽度高度是否等于屏幕的宽度高度。代码如下，大家参考：

procedure TForm1.Timer1Timer(Sender: TObject);
var
  topWindow: THandle;
  wRect: TRect;
begin
  topWindow := GetForegroundWindow;
  GetWindowRect(topWindow, wRect);
  if (wRect.Bottom = Screen.Height) and (wRect.Right = Screen.Width) then begin
    Memo1.Lines.Add('有全屏程序运行');
    //做你爱做的事……
  end else begin
    Memo1.Lines.Add('无全屏程序运行');
    //做你爱做的事……
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);

var

topWindow: THandle;

wRect: TRect;

begin

topWindow := GetForegroundWindow;

GetWindowRect(topWindow, wRect);

if (wRect.Bottom = Screen.Height) and (wRect.Right = Screen.Width) then begin

Memo1.Lines.Add('有全屏程序运行');

//做你爱做的事……

end else begin

Memo1.Lines.Add('无全屏程序运行');

//做你爱做的事……

end;

　　这种方法真是弱啊弱，看看第二种方法吧

方法二：

　　第二种方法是通过SHAppBarMessage函数给系统发送一个监听消息，用于监听一些关于AppBar的信息，该消息的第二个参数里有一个属性是用于指定回调消息的，程序中定义一个消息码用于监听。当传回的消息的wParam是ABN_FULLSCREENAPP 时判断lParam为真假来判断是进入全屏还是退出全屏。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, StdCtrls,
  ShellAPI; // 要引用此单元

const
  WM_APPBAR_MESSAGE = WM_USER + 1;

type
  TForm1 = class(TForm)
    Timer1: TTimer;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    IsFullScreenAppRun: Boolean; //放个全局变量用于记录
    procedure WMAppBarMessage(var Msg: TMessage); message WM_APPBAR_MESSAGE;
  end;

var
  Form1: TForm1;
  AppBar_Data: APPBARDATA;



implementation

{$R *.dfm}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  SHAppBarMessage(ABM_REMOVE, AppBar_Data); //窗口关闭时移除此消息
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FillChar(AppBar_Data, SizeOf(AppBar_Data), #0);
  AppBar_Data.cbSize := SizeOf(AppBar_Data);
  AppBar_Data.hWnd := Handle;
  AppBar_Data.uCallbackMessage := WM_APPBAR_MESSAGE; //指定回调消息
  SHAppBarMessage(ABM_NEW, AppBar_Data); //建立监听
end;

procedure TForm1.WMAppBarMessage(var Msg: TMessage);
var
  retCode: Cardinal ;
begin
  if Msg.Msg = WM_APPBAR_MESSAGE then begin
    if msg.WParam = ABN_FULLSCREENAPP then begin
      if msg.LParam = 1 then begin
        Memo1.Lines.Add('有全屏程序运行');
        IsFullScreenAppRun := True;
      end else if Msg.LParam = 0 then begin
        Memo1.Lines.Add('无全屏程序运行');
        IsFullScreenAppRun := False;
      end;
    end;
  end;
end;

end.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ExtCtrls, StdCtrls,

ShellAPI; // 要引用此单元

const

WM_APPBAR_MESSAGE = WM_USER + 1;

type

TForm1 = class(TForm)

Timer1: TTimer;

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

private

{ Private declarations }

public

IsFullScreenAppRun: Boolean; //放个全局变量用于记录

procedure WMAppBarMessage(var Msg: TMessage); message WM_APPBAR_MESSAGE;

end;

var

Form1: TForm1;

AppBar_Data: APPBARDATA;

implementation

{$R *.dfm}

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

SHAppBarMessage(ABM_REMOVE, AppBar_Data); //窗口关闭时移除此消息

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FillChar(AppBar_Data, SizeOf(AppBar_Data), #0);

AppBar_Data.cbSize := SizeOf(AppBar_Data);

AppBar_Data.hWnd := Handle;

AppBar_Data.uCallbackMessage := WM_APPBAR_MESSAGE; //指定回调消息

SHAppBarMessage(ABM_NEW, AppBar_Data); //建立监听

end;

procedure TForm1.WMAppBarMessage(var Msg: TMessage);

var

retCode: Cardinal ;

begin

if Msg.Msg = WM_APPBAR_MESSAGE then begin

if msg.WParam = ABN_FULLSCREENAPP then begin

if msg.LParam = 1 then begin

Memo1.Lines.Add('有全屏程序运行');

IsFullScreenAppRun := True;

end else if Msg.LParam = 0 then begin

Memo1.Lines.Add('无全屏程序运行');

IsFullScreenAppRun := False;

end;

end.

Delphi如何使子窗口显示在任务栏中

分类：Components, Delphi 阅读 (3,616) 1 Response »

8月 082014

在子窗口中重载CreateParams函数，并将WndParent设置为0即可，具体代码如下：

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
  private
    { Private declarations }
  public
    { Public declarations }
  protected
    //重载此函数
    procedure CreateParams(var Params: TCreateParams); Override;
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited;
  With Params do begin
    WndParent := 0;
  end;
end;

end.

unit Unit2;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs;

type

TForm2 = class(TForm)

private

{ Private declarations }

public

{ Public declarations }

protected

//重载此函数

procedure CreateParams(var Params: TCreateParams); Override;

end;

var

Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.CreateParams(var Params: TCreateParams);

begin

inherited;

With Params do begin

WndParent := 0;

end;

end.

当我们把Params.WndParent设置为0时，Delphi在调用CreateWindowEx创建该窗口时，会将hWndParent 参数设置为相同的值（此处为0），为0则意味着要创建的窗口的所有者为桌面。此值不能在运行期通过Windows ApI改变，可能是因为窗口的拥有者不能在运行期改变的原因。

一些有用的链接

CreateWindowEx function

MFC子窗口和父窗口（SetParent,SetOwner）

TRichEdit在Scrollbars为ssNone时滚轮滚动内容

分类：Components, Delphi 阅读 (2,620) No Responses »

7月 162014

在TRichEdit的Scrollbars属性为ssNone时，RichEdit中的内容超出边框大小时，翻动鼠标上下滚轮时，内容是不会自动滚动的。需要写代码实现此功能，主要是在RichEdit1MouseWheelUp和RichEdit1MouseWheelDown中发送消息实现，具体代码如下：

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    procedure RichEdit1MouseWheelDown(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
    procedure RichEdit1MouseWheelUp(Sender: TObject; Shift: TShiftState;
      MousePos: TPoint; var Handled: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.RichEdit1MouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  SendMessage(RichEdit1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
  Handled := True;
end;

procedure TForm1.RichEdit1MouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  SendMessage(RichEdit1.Handle, WM_VSCROLL, SB_LINEUP, 0);
  Handled := True;
end;

end.

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, ComCtrls, StdCtrls;

type

TForm1 = class(TForm)

RichEdit1: TRichEdit;

procedure RichEdit1MouseWheelDown(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

procedure RichEdit1MouseWheelUp(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.RichEdit1MouseWheelDown(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

SendMessage(RichEdit1.Handle, WM_VSCROLL, SB_LINEDOWN, 0);

Handled := True;

end;

procedure TForm1.RichEdit1MouseWheelUp(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

SendMessage(RichEdit1.Handle, WM_VSCROLL, SB_LINEUP, 0);

Handled := True;

end;

end.

FormMouseWheel、FormMouseWheelDown、FormMouseWheelUp执行多次的问题

分类：Components, Delphi 阅读 (4,321) No Responses »

5月 142014

当我们需要响应鼠标滚轮效果的时候，我们需要在Form的FormMouseWheel、FormMouseWheelDown、FormMouseWheelUp事件中进行处理。如下面的代码：

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Edit1.Top := Edit1.Top + 10;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Edit1.Top := Edit1.Top - 10;
end;

procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

Edit1.Top := Edit1.Top + 10;

end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

Edit1.Top := Edit1.Top - 10;

end;

但是在实际运行中我们发现，每次滚轮后Edit1的顶部位置往上或下移动了两次，这是因为TControl的DoMouseWheel调用了该事件，如果该事件中Handled返回值为true，则DoMouseWheel将认为该事件处理完毕，不在执行后边的代码，如果返回false则继续执行后面的代码。

所以如果要避免这几个事件执行多次，在执行完你要执行的操作后，返回Handled := True;即可。如下：

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
  MousePos: TPoint; var Handled: Boolean);
begin
  Edit1.Top := Edit1.Top - 10;
  Handled := True;
end;

procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;

MousePos: TPoint; var Handled: Boolean);

begin

Edit1.Top := Edit1.Top - 10;

Handled := True;

end;

DoMouseWheel的代码如下：

function TControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
var
  IsNeg: Boolean;
begin
  Result := False;
  if Assigned(FOnMouseWheel) then
    FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result);
  if not Result then
  begin
    Inc(FWheelAccumulator, WheelDelta);
    while Abs(FWheelAccumulator) >= WHEEL_DELTA do
    begin
      IsNeg := FWheelAccumulator < 0;
      FWheelAccumulator := Abs(FWheelAccumulator) - WHEEL_DELTA;
      if IsNeg then
      begin
        if FWheelAccumulator <> 0 then FWheelAccumulator := -FWheelAccumulator;
        Result := DoMouseWheelDown(Shift, MousePos);
      end
      else
        Result := DoMouseWheelUp(Shift, MousePos);
    end;
  end;
end;

function TControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;

MousePos: TPoint): Boolean;

var

IsNeg: Boolean;

begin

Result := False;

if Assigned(FOnMouseWheel) then

FOnMouseWheel(Self, Shift, WheelDelta, MousePos, Result);

if not Result then

begin

Inc(FWheelAccumulator, WheelDelta);

while Abs(FWheelAccumulator) >= WHEEL_DELTA do

begin

IsNeg := FWheelAccumulator < 0;

FWheelAccumulator := Abs(FWheelAccumulator) - WHEEL_DELTA;

if IsNeg then

begin

if FWheelAccumulator <> 0 then FWheelAccumulator := -FWheelAccumulator;

Result := DoMouseWheelDown(Shift, MousePos);

end

else

Result := DoMouseWheelUp(Shift, MousePos);

end;

Delphi中设置Combobox下拉项的宽度

分类：Components, Delphi 阅读 (3,896) No Responses »

11月 062013

　　在Delphi中下拉框条目的宽度总是和下拉框的宽度一样，当里面的项目太长时就不能显示全了。其实Windows提供了一个CB_SETDROPPEDWIDTH消息可能定义下拉框窗口的宽度，不知道为什么Delphi一直没有添加这个功能。使用方法很简单，如下：

　　SendMessage(cboIndustry.Handle, CB_SETDROPPEDWIDTH, 200, 0);

第一个参数是下拉框组件的句柄
第二个参数是要发送的消息
第三个参数是要设定的宽度
第四个参数未使用