Delphi – 蓝天白云

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.

点击下载源代码

Android中将Windows颜色转换为Android的颜色值

分类：Android, Delphi, Graphic, Java 阅读 (2,487) No Responses »

11月 122015

　　在Delphi中使用的颜色值(TColor)，同步到安卓后颜色不对了，因为没使用#FFFFFF这种16进制使用颜色，所以只能自己想办法转换了，经过研究下面的java代码转换成功：

	public static int WinColor2Android(int dcolor){
		int acolor = 0;
		
		byte b = (byte) (dcolor >> 16);
		byte g = (byte) (dcolor >> 8);
		byte r = (byte) (dcolor >> 0);	
		int ib = b & 0xff;
		int ig = g & 0xff;
		int ir = r & 0xff;
		
		acolor = Color.argb(255, ir, ig, ib);
		
		return acolor;
	}

public static int WinColor2Android(int dcolor){

int acolor = 0;

byte b = (byte) (dcolor >> 16);

byte g = (byte) (dcolor >> 8);

byte r = (byte) (dcolor >> 0);

int ib = b & 0xff;

int ig = g & 0xff;

int ir = r & 0xff;

acolor = Color.argb(255, ir, ig, ib);

return acolor;

}

　　因为Java中的byte是有符号的，范围是-127-128，所以要使用& 0xff转换为0-255之间的值。

Windows字体相关知识汇总

分类：Delphi, System 阅读 (1,894) No Responses »

11月 092015

1. 字体的一些单位

px – 像su
twips – 缇，1px = 15 twips
point – 点，1pt=1/72英吋

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开发中子窗口不能置顶的问题

分类：Delphi, System 阅读 (4,025) No Responses »

1月 062015

　　在Delphi开发中，如果我们想让一个窗口始终置顶显示，则我们只需要把窗口FormStyle属性设置为fsStayOnTop就可以了，但是如果这个窗口不是主窗口，而是子窗口，那就有些麻烦了，设置FormStyle为fsStayOnTop后也无效。解决办法就是在子窗口中重载CreateParams函数，并将WndParent设置为0即可，具体代码如下：

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
    Button1: TButton;
    Timer1: TTimer;
  private
    { Private declarations }
  public
    { Public declarations }
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

{ TForm2 }



procedure TForm2.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.WndParent := 0;
//  Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW; //如果不想在任务栏显示窗口图标
end;


end.

unit Unit2;

interface

uses

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

Dialogs, StdCtrls, ExtCtrls;

type

TForm2 = class(TForm)

Button1: TButton;

Timer1: TTimer;

private

{ Private declarations }

public

{ Public declarations }

protected

procedure CreateParams(var Params: TCreateParams); override;

end;

var

Form2: TForm2;

implementation

{$R *.dfm}

{ TForm2 }

procedure TForm2.CreateParams(var Params: TCreateParams);

begin

inherited;

Params.WndParent := 0;

// Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW; //如果不想在任务栏显示窗口图标

end;

end.

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

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.

Paypal添加招商银行一卡通

分类：Other, Others 阅读 (7,721) No Responses »

7月 122014

在PAYPAL帐户中添加自己的香港招行“香港一卡通”，需要填写以下信息：

(1)Name on account（帐户名称）：收款人名字，英文、中文？

(2) Bank Name（银行名称）：填写“CHINA MERCHANTS BANK HONG KONG BRANCH”；

(3) Account Type（帐户类型）：选择“Checking（支票收款）”；

(4) Bank Code（银行代码）：238，又叫CHATS CODE；

(5) Branch Location（分行地址）：21F，12 HARCOURT ROAD CENTRAL

(6) Branch Code（分行代码）：填写“860”这三位固定代码（即卡号中间的那三位）；

(7) Account Number（帐户号码）：填写你自己卡号的最后7位数字（即860之后的7位）；

(7) Re-Enter Account Number（重复帐户号码）：再次输入上面输入的7位收款帐号。

附截图：

其他信息：

1、招商銀行香港分行SWIFT CODE: CMBCHKHH

2、招商银行卡BIN号

信用卡：431988、356889、439225、439226、439227、518710、518718、622575、622576、622578、479229、479228、552534、552587、622581、622582、622577、521302、628362、356890、370285、370287、370289
借记卡：8位卡、955550、622580、622588、622609、621286、468203、512425、410062、524011、621483、621485、621486、621299

Delphi程序实现单实例运行

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

7月 092014

　　对于一些非多文档类的程序，我们只想让用户打开一个程序的实例，当用户再次点击图标的时候只需将原来运行的程序界面打开即可。那么如何实现这种功能呢？首先，要实现进程的单实例运行，我们可以用互斥对象实现，互斥对象即在系统层上只能创建一个这样标识的对象，当第二个此标识的互斥对象创建时将会返回一个已存在的标志。

　　单实例运行实现后，我们还要通过消息实现打开前面已经打开的窗口，我们可以用EnumWindows函数来遍例所有窗口以找到已打开窗口的句柄，并通过ShowWindow函数或者自定义消息来激活那个窗口。具体的代码如下：

program SingleProc;

uses
  Forms,
  TlHelp32,
  Windows,
  SysUtils,
  uFmSingleProc in 'uFmSingleProc.pas' {FmSingleProc};

{$R *.res}

var
  HMutex: Hwnd;
  Ret: Integer;
  I: integer;

// 根据进程ID获取进程名称
function GetProcessNameById(const AID: Integer): String;
var
  h:thandle;
  f:boolean;
  lppe:tprocessentry32;
begin
  Result := '';
  h := CreateToolhelp32Snapshot(TH32cs_SnapProcess, 0);
  lppe.dwSize := sizeof(lppe);
  f := Process32First(h, lppe);
  while integer(f) <> 0 do
  begin
    if Integer(lppe.th32ProcessID) = AID then
    begin
      Result:= StrPas(lppe.szExeFile);
      break;
    end;
    f := Process32Next(h, lppe);
  end;
end;

function EnumWindowsOpen1stApp(hwnd: HWND; lParam: LPARAM): Boolean ;stdcall;
var
  WindowText   : string  ;       // 窗体标题
  procId: Cardinal;
  wText: array[0..255] of char;
begin
  // 获取进程ID
  GetWindowThreadProcessId(HWND, procId);

  if GetProcessNameById(procId) = ExtractFileName(Application.ExeName) then begin
    GetWindowText(HWND, @wText, 255);
    if wText = 'Form Title' then begin
      //ShowWindow有的时候会导致其他的问题，如果ShowWindow有问题可以用下面的发送消息的方法解决
      //ShowWindow(hwnd, SW_SHOW);

      //通过发送消息方式来激活前面的窗口
      SendMessage(hwnd, WM_SHOWTHEFORM, 0, 0);
    end;
  end;
  Result := True;
end;

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;

  hMutex := CreateMutex(nil, False, PChar('SingleProcTest'));
  Ret := GetLastError ;
  if Ret <> ERROR_ALREADY_EXISTS Then
  begin
    Application.CreateForm(TFmSingleProc, FmSingleProc);
  end else begin
    // 互斥对象已存在，则遍历查找已打开的程序
    EnumWindows(@EnumWindowsOpen1stApp, 0);
    ReleaseMutex(hMutex);
  end;
  Application.Run;
end.

program SingleProc;

uses

Forms,

TlHelp32,

Windows,

SysUtils,

uFmSingleProc in 'uFmSingleProc.pas' {FmSingleProc};

{$R *.res}

var

HMutex: Hwnd;

Ret: Integer;

I: integer;

// 根据进程ID获取进程名称

function GetProcessNameById(const AID: Integer): String;

var

h:thandle;

f:boolean;

lppe:tprocessentry32;

begin

Result := '';

h := CreateToolhelp32Snapshot(TH32cs_SnapProcess, 0);

lppe.dwSize := sizeof(lppe);

f := Process32First(h, lppe);

while integer(f) <> 0 do

begin

if Integer(lppe.th32ProcessID) = AID then

begin

Result:= StrPas(lppe.szExeFile);

break;

end;

f := Process32Next(h, lppe);

end;

function EnumWindowsOpen1stApp(hwnd: HWND; lParam: LPARAM): Boolean ;stdcall;

var

WindowText : string ; // 窗体标题

procId: Cardinal;

wText: array[0..255] of char;

begin

// 获取进程ID

GetWindowThreadProcessId(HWND, procId);

if GetProcessNameById(procId) = ExtractFileName(Application.ExeName) then begin

GetWindowText(HWND, @wText, 255);

if wText = 'Form Title' then begin

//ShowWindow有的时候会导致其他的问题，如果ShowWindow有问题可以用下面的发送消息的方法解决

//ShowWindow(hwnd, SW_SHOW);

//通过发送消息方式来激活前面的窗口

SendMessage(hwnd, WM_SHOWTHEFORM, 0, 0);

end;

Result := True;

end;

begin

Application.Initialize;

Application.MainFormOnTaskbar := True;

hMutex := CreateMutex(nil, False, PChar('SingleProcTest'));

Ret := GetLastError ;

if Ret <> ERROR_ALREADY_EXISTS Then

begin

Application.CreateForm(TFmSingleProc, FmSingleProc);

end else begin

// 互斥对象已存在，则遍历查找已打开的程序

EnumWindows(@EnumWindowsOpen1stApp, 0);

ReleaseMutex(hMutex);

end;

Application.Run;

end.

unit uFmSingleProc;

interface

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

const
  WM_SHOWTHEFORM = WM_USER + 1;

type
  TFmSingleProc = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    // 如果通过ShowWindow函数显示窗口，则不用此消息
    procedure WMShowTheForm(Var msg: TMessage); message WM_SHOWTHEFORM;
  end;

var
  FmSingleProc: TFmSingleProc;

implementation

{$R *.dfm}

{ TFmSingleProc }

procedure TFmSingleProc.FormCreate(Sender: TObject);
begin
  Self.Caption := 'Form Title';
end;

procedure TFmSingleProc.WMShowTheForm(var msg: TMessage);
begin
  Self.WindowState := wsNormal ;
  Self.Show;
  Self.BringToFront ;
end;

end.

unit uFmSingleProc;

interface

uses

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

Dialogs;

const

WM_SHOWTHEFORM = WM_USER + 1;

type

TFmSingleProc = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

// 如果通过ShowWindow函数显示窗口，则不用此消息

procedure WMShowTheForm(Var msg: TMessage); message WM_SHOWTHEFORM;

end;

var

FmSingleProc: TFmSingleProc;

implementation

{$R *.dfm}

{ TFmSingleProc }

procedure TFmSingleProc.FormCreate(Sender: TObject);

begin

Self.Caption := 'Form Title';

end;

procedure TFmSingleProc.WMShowTheForm(var msg: TMessage);

begin

Self.WindowState := wsNormal ;

Self.Show;

Self.BringToFront ;

end;

end.

Page 1 of 5 1 2 3 4 5 Older Entries