System – 蓝天白云

Windows字体相关知识汇总

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

11月 092015

1. 字体的一些单位

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

Delphi开发中子窗口不能置顶的问题

分类：Delphi, System 阅读 (3,758) 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 阅读 (2,840) 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程序实现单实例运行

分类：Delphi, System 阅读 (3,157) 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.

使用Delphi创建Windows服务程序

分类：Delphi, System 阅读 (5,330) No Responses »

6月 092014

Windows服务作为Windows提供的一种特殊应用程序，拥有下面优点：

1. 随系统启动而启动，不需要用户手动执行，适合做后台检测程序等
2. 不用登录系统即可运行
3. 在后台运行，不与Windows桌面相互影响
4. 拥有System权限，在任务管理器中无法结束运行

Windows不建议在服务程序中与桌面有交互，在Windows Xp及以前的版本Windows服务和用户桌面还运行在一个session下，所以服务程序还可以比较轻松的与桌面进行交互。但是自Windows Vista及以后的系统中，服务程序是运行于session0中，而第一个启动的用户则运行于session1中，要想在服务中显示桌面或者与桌面程序交互要使用很复杂的技术，甚至用CreateProcess和ShellExecute启动的应用程序都无法在用户桌面中显示。

一、在Delphi中创建Windows服务程序

Delphi中提供了创建Windows服务的程序框架，生成Windows服务工程的具体方法如下，点击菜单File->New->Other，在里面寻找Service Application项目，点击OK按钮生成即可。这里会生成一个带界面的TService1类。选中TService1界面，下面介绍一下TService的相关属性和事件。

TService属性：

AllowPause: 是否允许暂停
AllowStop: 是否允许停止
Dependencies: 设置该服务与其他服务的依赖关系
DisplayName: 在Windows服务管理器中显示的名称（注意：不是服务名）
Name: 服务名称，使用/install参数安装时安装的服务名为此属性值
Interactive: 是否要与桌面进行交互
StartType: 服务的启动方式
ServiceStartName: 设定用于启动服务的用户名

TService事件：

1. procedure TService1.ServiceStart(Sender: TService; var Started: Boolean);
在该服务启动的时候调用OnStart事件，参数Started的默认为True，所以不用在该事件中再设置Started := True;　在此事件中如果判断某些条件不允许服务运行，则可以将Started置为False，这样服务将会不再启动。
2. procedure TService1.ServiceStop(Sender: TService; var Stopped: Boolean);
在该服务被停止的时候调用OnStop事件，Stopped的默认为True，在此事件中如果判断某些条件不允许服务停止则可将Stopped置为False来防止服务被停止。
3. procedure TService1.ServiceExecute(Sender: TService);
服务的主体执行部分，需要将服务的主要功能实现代码放在此事件中，此过程执行完毕后服务将会自动停止，所以一般在此事件中要写类似如下代码：

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

procedure TService1.ServiceExecute(Sender: TService);

begin

while not Terminated do

begin

Sleep(10);

ServiceThread.ProcessRequests(False);

end;

4.procedure TService1.ServicePause(Sender: TService; var Paused: Boolean);
在服务被暂停时调用的事件，Paused的含义类似ServiceStart事件中的Started.
5. procedure TService1.ServiceContinue(Sender: TService; var Continued: Boolean);
服务被暂停后重新启动继续执行时调用的事件，Continued的含义类似ServiceStart事件中的Started

经过简单的点击后，一个最基本的Windows服务程序已经编写完成了，编译工程，将会生成一个exe程序，本例中生成一个ServiceTest.exe。
打开命令行窗口，将目录定位到工程的输出目录，输入ServiceTest.exe /install并执行，刚才编写的服务就安装到系统中了。
卸载服务时使用ServiceTest.exe /unstall
可以在命令行后面加/silent参数，使其不弹出安装、卸载成功的提示框。
注意：使用/install这种方式安装时，服务的名字是服务窗口的类名，不是DisplayName，服务管理器中显示的是DisplayName
也可使用Windows自带的sc命令来创建或者删除服务，创建的示例代码如下：

sc create "ServiceName" binpath= "C:UsersAdministratorDesktopServiceTestServiceTest.exe"
sc delete ServiceName

1 2	sc create "ServiceName" binpath= "C:UsersAdministratorDesktopServiceTestServiceTest.exe" sc delete ServiceName

二、一些很有用的管理服务的函数

unit ServiceMgr;

interface
  uses Windows,Messages,SysUtils,Winsvc,Dialogs;

  function StartServices(Const  SvrName:String):Boolean;
  function StopServices(Const  SvrName:String):Boolean;
  function QueryServiceStatu(Const SvrName:   String):String;
  function CreateServices(Const SvrName,FilePath:String):Boolean;
  function DeleteServices(Const SvrName: String):Boolean;
  function IsServiceExisted(Const SvrName: String):Boolean;

implementation

//开启服务
function StartServices(Const SvrName: String): Boolean;
var
  sMgr, sHandle:SC_HANDLE;
  c:PChar;
begin
  Result:=False;

  sMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if sMgr <=0 then Exit;

  sHandle := OpenService(sMgr, PChar(SvrName), SERVICE_ALL_ACCESS);
  if sHandle <=0 then Exit;

  try
    Result:=StartService(sHandle, 0, c);
    CloseServiceHandle(sHandle);
    CloseServiceHandle(sMgr);
  except
    CloseServiceHandle(sHandle);
    CloseServiceHandle(sMgr);
  end;
end;

//停止服务
function StopServices(Const SvrName: String): Boolean;
var
  sMgr, sHandle: SC_HANDLE;
  d: TServiceStatus;
begin
  Result := False;

  sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  if sMgr <=0 then Exit;
  sHandle := OpenService(sMgr,PChar(SvrName),SERVICE_ALL_ACCESS);
  if sHandle <=0 then Exit;
  try
    Result:=ControlService(sHandle, SERVICE_CONTROL_STOP,d);
    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);
  except
    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);
  end;
end;

//查询当前服务的状态
function  QueryServiceStatu(Const SvrName: String): String;
var
  sMgr, sHandle: SC_HANDLE;
  d: TServiceStatus;
begin
  Result := '未安装';

  sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  if sMgr <=0 then Exit;
  sHandle := OpenService(sMgr,PChar(SvrName),SERVICE_ALL_ACCESS);

  if sHandle <= 0 then Exit;
  try
    QueryServiceStatus(sHandle, d);
  if d.dwCurrentState  = SERVICE_RUNNING then
    Result := '启动'   //Run
  else if d.dwCurrentState   = SERVICE_RUNNING then
    Result := 'Wait'   //Runing
  else if d.dwCurrentState   = SERVICE_START_PENDING then
    Result := 'Wait'   //Pause
  else if d.dwCurrentState   = SERVICE_STOP_PENDING   then
    Result := '停止'   //Pause
  else if d.dwCurrentState   = SERVICE_PAUSED then
    Result := '暂停'   //Pause
  else if d.dwCurrentState   = SERVICE_STOPPED then
    Result := '停止'   //Stop
  else if d.dwCurrentState   = SERVICE_CONTINUE_PENDING   then
    Result := 'Wait'   //Pause
  else if d.dwCurrentState   = SERVICE_PAUSE_PENDING then
    Result := 'Wait';   //Pause

    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);
  except
    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);
  end;
end;

{建立服务}
function  CreateServices(Const SvrName,FilePath: String): Boolean;
var
  sMgr, sHandle:SC_HANDLE;
begin
  Result:=False;
  if FilePath = '' then Exit;

  sMgr := OpenSCManager(nil,nil,SC_MANAGER_CREATE_SERVICE);

  if sMgr <= 0 then Exit;
  try
    sHandle := CreateService(sMgr, PChar(SvrName),
    PChar(SvrName),
    SERVICE_ALL_ACCESS,
    SERVICE_INTERACTIVE_PROCESS or SERVICE_WIN32_OWN_PROCESS,
    SERVICE_AUTO_START,SERVICE_ERROR_NORMAL,
    PChar(FilePath),nil,nil,nil,nil,nil);
    if sHandle <= 0 then begin
      ShowMessage( SysErrorMessage(GetlastError));
      Exit;
    end;
    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);

    Result := True;
  except
    CloseServiceHandle(sMgr);
    CloseServiceHandle(sHandle);
    Exit;
  end;
end;

{卸载服务}
function DeleteServices(Const SvrName: String): Boolean;
var
  sMgr, sHandle:SC_HANDLE;
begin
  Result:=False;
  sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  if sMgr <= 0 then  Exit;
  sHandle :=OpenService(sMgr,PChar(SvrName),STANDARD_RIGHTS_REQUIRED);
  if sHandle <= 0 then Exit;
  try
    Result := DeleteService(sHandle);

    if not Result then
      ShowMessage(SysErrorMessage(GetlastError));
    CloseServiceHandle(sHandle);
    CloseServiceHandle(sMgr);
  except
    CloseServiceHandle(sHandle);
    CloseServiceHandle(sMgr);
    Exit;
  end;
end;

function IsServiceExisted(Const SvrName: String):Boolean;
var
  sMgr, sHandle:SC_HANDLE;
begin
  Result:=False;
  sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);
  if sMgr <= 0 then  Exit;
  sHandle :=OpenService(sMgr, PChar(SvrName), STANDARD_RIGHTS_REQUIRED);
  if sHandle > 0 then
    Result := True;
end;

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

unit ServiceMgr;

interface

uses Windows,Messages,SysUtils,Winsvc,Dialogs;

function StartServices(Const SvrName:String):Boolean;

function StopServices(Const SvrName:String):Boolean;

function QueryServiceStatu(Const SvrName: String):String;

function CreateServices(Const SvrName,FilePath:String):Boolean;

function DeleteServices(Const SvrName: String):Boolean;

function IsServiceExisted(Const SvrName: String):Boolean;

implementation

//开启服务

function StartServices(Const SvrName: String): Boolean;

var

sMgr, sHandle:SC_HANDLE;

c:PChar;

begin

Result:=False;

sMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);

if sMgr <=0 then Exit;

sHandle := OpenService(sMgr, PChar(SvrName), SERVICE_ALL_ACCESS);

if sHandle <=0 then Exit;

try

Result:=StartService(sHandle, 0, c);

CloseServiceHandle(sHandle);

CloseServiceHandle(sMgr);

except

CloseServiceHandle(sHandle);

CloseServiceHandle(sMgr);

end;

//停止服务

function StopServices(Const SvrName: String): Boolean;

var

sMgr, sHandle: SC_HANDLE;

d: TServiceStatus;

begin

Result := False;

sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

if sMgr <=0 then Exit;

sHandle := OpenService(sMgr,PChar(SvrName),SERVICE_ALL_ACCESS);

if sHandle <=0 then Exit;

try

Result:=ControlService(sHandle, SERVICE_CONTROL_STOP,d);

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

except

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

end;

//查询当前服务的状态

function QueryServiceStatu(Const SvrName: String): String;

var

sMgr, sHandle: SC_HANDLE;

d: TServiceStatus;

begin

Result := '未安装';

sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

if sMgr <=0 then Exit;

sHandle := OpenService(sMgr,PChar(SvrName),SERVICE_ALL_ACCESS);

if sHandle <= 0 then Exit;

try

QueryServiceStatus(sHandle, d);

if d.dwCurrentState = SERVICE_RUNNING then

Result := '启动' //Run

else if d.dwCurrentState = SERVICE_RUNNING then

Result := 'Wait' //Runing

else if d.dwCurrentState = SERVICE_START_PENDING then

Result := 'Wait' //Pause

else if d.dwCurrentState = SERVICE_STOP_PENDING then

Result := '停止' //Pause

else if d.dwCurrentState = SERVICE_PAUSED then

Result := '暂停' //Pause

else if d.dwCurrentState = SERVICE_STOPPED then

Result := '停止' //Stop

else if d.dwCurrentState = SERVICE_CONTINUE_PENDING then

Result := 'Wait' //Pause

else if d.dwCurrentState = SERVICE_PAUSE_PENDING then

Result := 'Wait'; //Pause

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

except

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

end;

{建立服务}

function CreateServices(Const SvrName,FilePath: String): Boolean;

var

sMgr, sHandle:SC_HANDLE;

begin

Result:=False;

if FilePath = '' then Exit;

sMgr := OpenSCManager(nil,nil,SC_MANAGER_CREATE_SERVICE);

if sMgr <= 0 then Exit;

try

sHandle := CreateService(sMgr, PChar(SvrName),

PChar(SvrName),

SERVICE_ALL_ACCESS,

SERVICE_INTERACTIVE_PROCESS or SERVICE_WIN32_OWN_PROCESS,

SERVICE_AUTO_START,SERVICE_ERROR_NORMAL,

PChar(FilePath),nil,nil,nil,nil,nil);

if sHandle <= 0 then begin

ShowMessage( SysErrorMessage(GetlastError));

Exit;

end;

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

Result := True;

except

CloseServiceHandle(sMgr);

CloseServiceHandle(sHandle);

Exit;

end;

{卸载服务}

function DeleteServices(Const SvrName: String): Boolean;

var

sMgr, sHandle:SC_HANDLE;

begin

Result:=False;

sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

if sMgr <= 0 then Exit;

sHandle :=OpenService(sMgr,PChar(SvrName),STANDARD_RIGHTS_REQUIRED);

if sHandle <= 0 then Exit;

try

Result := DeleteService(sHandle);

if not Result then

ShowMessage(SysErrorMessage(GetlastError));

CloseServiceHandle(sHandle);

CloseServiceHandle(sMgr);

except

CloseServiceHandle(sHandle);

CloseServiceHandle(sMgr);

Exit;

end;

function IsServiceExisted(Const SvrName: String):Boolean;

var

sMgr, sHandle:SC_HANDLE;

begin

Result:=False;

sMgr := OpenSCManager(nil,nil,SC_MANAGER_ALL_ACCESS);

if sMgr <= 0 then Exit;

sHandle :=OpenService(sMgr, PChar(SvrName), STANDARD_RIGHTS_REQUIRED);

if sHandle > 0 then

Result := True;

end;

end.

调用方法：

{启动服务} StartServices(服务名);
{停止服务} StopServices(服务名);
{新建服务} CreateServices(服务名,exe文件路径);
{删除服务} DeleteServices(服务名);
{获取服务状态} string:=QueryServiceStatu(服务名);

注意这里的服务名是Service类的名称，不是DisplayName

三、Delphi中编写Windows服务的注意事项

1. 尽量避免使用ShowMessage等直接进行调试，容易造成服务无法响应等问题。
2. 停止服务时提示”Windows无法停止 xxx 服务（位于　本地计算机　上）” ，则可能是OnStop事件结束时将Stopped设置成了False或者OnExecute事件不能结束或者OnExecute与界面进行了不正确的交互。
3. Windows Vista及上版本的系统中不再支持服务中显示窗口，所以在这些版本的系统上，如果需要显示窗口，则要另外创建一个窗口程序，并与之用消息通讯以显示窗口。

四、一些有用的链接

Subverting Vista UAC in Both 32 and 64 bit Architectures
http://www.codeproject.com/Articles/35773/Subverting-Vista-UAC-in-Both-and-bit-Archite

如何在Windows Service里面运行程序
http://blog.sina.com.cn/s/blog_5f8817250100vooy.html

Delphi使用大图标编译程序

分类：Delphi, System 阅读 (5,613) No Responses »

11月 232013

　　在Windows Vista、 Windows7以上Windows系统中可以支持大图标显示了，但是Delphi编译出来的程序却只能显示32×32的图标，这使Delphi编译的程序看起来很不专业。下面就把Delphi编译大图标程序的方法分享一下。

　　要想使用大图标编译，首先要准备一个256×256的图标图片。

　　使用图标编辑软件，如IconWorkshop打开你的 ico文件，新建一个256×256的真彩色图标，将你的图片文件导入到该图标中。保存图标后，将图标文件拷贝到你的工程目录下，假设为mainico.ico，然后在你的工程下面建一个mainico.rc的文件，在里面输入文本：

　　MAINICON ICON mainico.ico

　　打开命令行窗口，将目录切换到你的工程目录下，输入命令rc mainico.rc，按回车执行，这时在你的工程目录下会生成一个mainico.RES文件。

　　在Delphi中打开你的工程，选择菜单Project->View Source，在{$R *.res}下面加上一行{$R Mainico.RES}，再编译程序就可以了。

　　Windows系统会对图标缓存，所以刚编译完可能看不到效果，可以将编译后的程序拷贝到其他地方，看是否变成大图标了。

　　rc命令为调用的Microsoft Windows Resource Compiler

Delphi实现窗口一直在桌面工作区内显示

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

11月 162013

　　有的时候我们要实现一个悬浮窗口，并使该窗口一直显示在桌面的工作区内。即整个窗口要一直显示在屏幕上，不能超出屏幕的上下左右边缘。此功能的实现也不难，我们需要自己写代码来响应窗口的WM_WINDOWPOSCHANGING消息，话不多说，详细代码如下供参考：

　　新建一个工程，并把下面代码拷贝到工程中，运行……

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
  private
    procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
  inherited;
  if (Message.WindowPos.y + Message.WindowPos.cy  > Screen.WorkAreaHeight) then begin
    Message.WindowPos.Y := Screen.WorkAreaHeight - Height ;
  end;
  if (Message.WindowPos.x + Message.WindowPos.cx > Screen.WorkAreaWidth) then begin
    Message.WindowPos.X := Screen.WorkAreaWidth - Width ;
  end;

  if Message.WindowPos.x < 0 then
    Message.WindowPos.x := 0;

  if Message.WindowPos.y < 0 then
    Message.WindowPos.y := 0;
end;

end.

unit Unit1;

interface

uses

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

Dialogs;

type

TForm1 = class(TForm)

private

procedure WMWindowPosChanging(var Message: TWMWindowPosChanging); message WM_WINDOWPOSCHANGING;

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);

begin

inherited;

if (Message.WindowPos.y + Message.WindowPos.cy > Screen.WorkAreaHeight) then begin

Message.WindowPos.Y := Screen.WorkAreaHeight - Height ;

end;

if (Message.WindowPos.x + Message.WindowPos.cx > Screen.WorkAreaWidth) then begin

Message.WindowPos.X := Screen.WorkAreaWidth - Width ;

end;

if Message.WindowPos.x < 0 then

Message.WindowPos.x := 0;

if Message.WindowPos.y < 0 then

Message.WindowPos.y := 0;

end;

end.

WM_SYSCOMMAND消息命令整理

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

1月 172013

注意：
1. 使用WM_SYSCOMMAND时，鼠标的一些消息可能会受到影响，比如不能响应MouseUp事件，可以在窗口中捕获WM_SYSCOMMAND消息，并判断消息的CommandType来判断消息执行完毕的情况

SC_CLOSE 关闭窗口
SC_HOTKEY Activate the window associated with the application-specified hot key.
SC_HSCROLL Scroll horizontally.
SC_KEYMENU Retrieve a menu through a keystroke.
SC_MAXIMIZE 最大化窗口
SC_MINIMIZE 最小化窗口.
SC_MOUSEMENU Retrieve a menu through a mouse click.
SC_MOVE Move the window.
SC_NEXTWINDOW Move to the next window.
SC_PREVWINDOW Move to the previous window.
SC_RESTORE Save the previous coordinates (checkpoint).
SC_SCREENSAVE 激活屏幕保护程序.
SC_SIZE Size the window.
SC_TASKLIST 激活开始菜单.
SC_VSCROLL Scroll vertically.
SC_MONITORPOWER 关闭显示器(LPARAM为非0参数)
SC_SEPARATOR
SC_CONTEXTHELP 显示帮助
SC_DEFAULT

SC_SIZE = $F000
SC_MOVE = $F010
SC_MINIMIZE = $F020
SC_MAXIMIZE = $F030
SC_NEXTWINDOW = $F040
SC_PREVWINDOW = $F050
SC_CLOSE = $F060
SC_VSCROLL = $F070
SC_HSCROLL = $F080
SC_MOUSEMENU = $F090
SC_KEYMENU = $F100
SC_ARRANGE = $F110
SC_RESTORE = $F120
SC_TASKLIST = $F130
SC_SCREENSAVE = $F140
SC_HOTKEY = $F150
SC_DEFAULT = $F160
SC_MONITORPOWER = $F170
SC_CONTEXTHELP = $F180
SC_SEPARATOR = $F00F
有的时候我们看到一些这里没有的命令，比如用鼠标拖动控件时用的panel1.Perform(WM_SYSCOMMAND, $F012, 0);这个$F012这个命令在定义里没有，其实它是SC_MOVE or 2的结果，微软的文档中提到WM_SYSCOMMAND命令中wParam的值的低4位值是保留的。
举例说明：
在Form的MouseDown事件里写如下代码
ReleaseCapture;
Perform(WM_SYSCOMMAND, SC_SIZE OR 1, 0); // Left
Perform(WM_SYSCOMMAND, SC_SIZE OR 2, 0); // Right
Perform(WM_SYSCOMMAND, SC_SIZE OR 3, 0); // Top
Perform(WM_SYSCOMMAND, SC_SIZE OR 4, 0); // left-top
Perform(WM_SYSCOMMAND, SC_SIZE OR 5, 0); // Right-top
Perform(WM_SYSCOMMAND, SC_SIZE OR 6, 0); // bottom
Perform(WM_SYSCOMMAND, SC_SIZE OR 7, 0); // left-bottom
Perform(WM_SYSCOMMAND, SC_SIZE OR 8, 0); // right-bottom

在Delphi 2009及更高版本中谨慎使用AnsiString

分类：System 阅读 (2,629) No Responses »

12月 102012

因为在Delphi 2009及更高的版本中，已增加对Unicode的支持，所以当在此版本中调用Windows Api的时候调用的都是Unicode版本的Api，比如：调用CreateProcess时实际是调用的CreateProcessW，在之前的版本则是调用的是CreateProcessA。

同样地，如果声明的是string类型，则此变量也是Unicode类型的字符串变量，使用此种类型的变量作为参数是没有问题，但是如果把变量强制声明成了AnsiString再作为参数传入的话则会出现问题了。

以CreateFile函数为例，第一个参数为lpFileName，为要打开的文件路径，如果传入的是String类型的变量，则可以执行成功，如果传入的是AnsiString类型的变量则会失败，用GetLastError会得到文件未找到的错误ERROR_FILE_NOT_FOUND (2)。