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.

点击下载源代码

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.

使用Delphi创建Windows服务程序

分类：Delphi, System 阅读 (5,754) 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

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使用大图标编译程序

分类：Delphi, System 阅读 (5,812) 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中设置Combobox下拉项的宽度

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

11月 062013

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

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

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

Delphi中读取Outlook的数据

分类：Delphi, Other 阅读 (4,139) No Responses »

9月 172013

Delphi中读取Outlook的数据，代码如下：

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    btnGetData: TButton;
    lvCalendar: TListView;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    lvContact: TListView;
    procedure btnGetDataClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnGetDataClick(Sender: TObject);
var
  i, J: Integer;
  Outlook, Namespace, Appointment, Calendar: variant;
  Created: Boolean;
  Accept: Boolean;
  MyItems: Variant;
  apptItem, Contacts, cItem: Variant;

const
  olAppointmentItem = 1;

  olFolderCalendar =	9;//	The Calendar folder.
  olFolderConflicts	=19;//	The Conflicts folder (subfolder of Sync Issues folder). Only available for an Exchange account.
  olFolderContacts	=10;//	The Contacts folder.
  olFolderDeletedItems =	3;//	The Deleted Items folder.
  olFolderDrafts =	16;//	The Drafts folder.
  olFolderInbox	=6;//	The Inbox folder.
  olFolderJournal=	11;//	The Journal folder.
  olFolderJunk =	23;//	The Junk E-Mail folder.
  olFolderLocalFailures	=21;//	The Local Failures folder (subfolder of Sync Issues folder). Only available for an Exchange account.
  olFolderManagedEmail =	29;//	The top-level folder in the Managed Folders group. For more information on Managed Folders, see Help in Microsoft Outlook. Only available for an Exchange account.
  olFolderNotes=	12 ;//	The Notes folder.
  olFolderOutbox =	4;//	The Outbox folder.
  olFolderSentMail =	5;//	The Sent Mail folder.
  olFolderServerFailures =	22;//	The Server Failures folder (subfolder of Sync Issues folder). Only available for an Exchange account.
  olFolderSyncIssues =	20;//	The Sync Issues folder. Only available for an Exchange account.
  olFolderTasks=	13;//	The Tasks folder.
  olFolderToDo	=28;//	The To Do folder.
  olPublicFoldersAllPublicFolders=	18;//	The All Public Folders folder in the Exchange Public Folders store. Only available for an Exchange account.
  olFolderRssFeeds =	25;//	The RSS Feeds folder.

begin
  lvCalendar.Clear ;
  Created := False;

  try
    Outlook := CreateOleObject('Outlook.Application');
  except
    Created := True;
  end;

  Namespace := Outlook.GetNamespace('MAPI');
  Calendar := Namespace.GetDefaultFolder(olFolderCalendar);

  for I := 1 to Calendar.Items.count  do begin
    Appointment := Calendar.Items[i];
    try
      With lvCalendar.Items.Add do begin
        Caption := Appointment.Subject;
        SubItems.Add(Appointment.Start);
        SubItems.Add(Appointment.End);
        SubItems.Add(Appointment.Duration);
        SubItems.Add(Appointment.Location);
        SubItems.Add(Appointment.Body);
      end;
    except

    end;
  end;

  Contacts := Namespace.GetDefaultFolder(olFolderContacts);
  for I := 1 to Contacts.Items.Count do begin
    Citem := Contacts.Items[I];
    try
      With lvContact.Items.Add do begin
        Caption := cItem.FirstName;
        SubItems.Add(cItem.LastName);
        SubItems.Add(cItem.MiddleName);
        SubItems.Add(cItem.Gender);
        SubItems.Add(cItem.Birthday);
        SubItems.Add(cItem.Email1Address);
        SubItems.Add(cItem.Email1AddressType);
        SubItems.Add(cItem.HomeTelephoneNumber);
      end;
    except

    end;
  end;

  if Created then
    Outlook := unassigned;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PageControl1.ActivePageIndex := 0;
end;

end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

unit Unit1;

interface

uses

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

Dialogs, StdCtrls, activex, ComObj, ComCtrls;

type

TForm1 = class(TForm)

btnGetData: TButton;

lvCalendar: TListView;

PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

lvContact: TListView;

procedure btnGetDataClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btnGetDataClick(Sender: TObject);

var

i, J: Integer;

Outlook, Namespace, Appointment, Calendar: variant;

Created: Boolean;

Accept: Boolean;

MyItems: Variant;

apptItem, Contacts, cItem: Variant;

const

olAppointmentItem = 1;

olFolderCalendar = 9;// The Calendar folder.

olFolderConflicts =19;// The Conflicts folder (subfolder of Sync Issues folder). Only available for an Exchange account.

olFolderContacts =10;// The Contacts folder.

olFolderDeletedItems = 3;// The Deleted Items folder.

olFolderDrafts = 16;// The Drafts folder.

olFolderInbox =6;// The Inbox folder.

olFolderJournal= 11;// The Journal folder.

olFolderJunk = 23;// The Junk E-Mail folder.

olFolderLocalFailures =21;// The Local Failures folder (subfolder of Sync Issues folder). Only available for an Exchange account.

olFolderManagedEmail = 29;// The top-level folder in the Managed Folders group. For more information on Managed Folders, see Help in Microsoft Outlook. Only available for an Exchange account.

olFolderNotes= 12 ;// The Notes folder.

olFolderOutbox = 4;// The Outbox folder.

olFolderSentMail = 5;// The Sent Mail folder.

olFolderServerFailures = 22;// The Server Failures folder (subfolder of Sync Issues folder). Only available for an Exchange account.

olFolderSyncIssues = 20;// The Sync Issues folder. Only available for an Exchange account.

olFolderTasks= 13;// The Tasks folder.

olFolderToDo =28;// The To Do folder.

olPublicFoldersAllPublicFolders= 18;// The All Public Folders folder in the Exchange Public Folders store. Only available for an Exchange account.

olFolderRssFeeds = 25;// The RSS Feeds folder.

begin

lvCalendar.Clear ;

Created := False;

try

Outlook := CreateOleObject('Outlook.Application');

except

Created := True;

end;

Namespace := Outlook.GetNamespace('MAPI');

Calendar := Namespace.GetDefaultFolder(olFolderCalendar);

for I := 1 to Calendar.Items.count do begin

Appointment := Calendar.Items[i];

try

With lvCalendar.Items.Add do begin

Caption := Appointment.Subject;

SubItems.Add(Appointment.Start);

SubItems.Add(Appointment.End);

SubItems.Add(Appointment.Duration);

SubItems.Add(Appointment.Location);

SubItems.Add(Appointment.Body);

end;

except

end;

Contacts := Namespace.GetDefaultFolder(olFolderContacts);

for I := 1 to Contacts.Items.Count do begin

Citem := Contacts.Items[I];

try

With lvContact.Items.Add do begin

Caption := cItem.FirstName;

SubItems.Add(cItem.LastName);

SubItems.Add(cItem.MiddleName);

SubItems.Add(cItem.Gender);

SubItems.Add(cItem.Birthday);

SubItems.Add(cItem.Email1Address);

SubItems.Add(cItem.Email1AddressType);

SubItems.Add(cItem.HomeTelephoneNumber);

end;

except

end;

if Created then

Outlook := unassigned;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

PageControl1.ActivePageIndex := 0;

end;

end.

Form代码：

object Form1: TForm1
  Left = 450
  Top = 238
  BorderIcons = [biSystemMenu]
  BorderStyle = bsDialog
  Caption = 'Outlook reader test'
  ClientHeight = 604
  ClientWidth = 985
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object btnGetData: TButton
    Left = 16
    Top = 568
    Width = 161
    Height = 25
    Caption = 'Get Data From Outlook'
    TabOrder = 0
    OnClick = btnGetDataClick
  end
  object PageControl1: TPageControl
    Left = 8
    Top = 8
    Width = 961
    Height = 545
    ActivePage = TabSheet2
    TabOrder = 1
    object TabSheet1: TTabSheet
      Caption = 'Appointment'
      object lvCalendar: TListView
        Left = 0
        Top = 0
        Width = 953
        Height = 517
        Align = alClient
        Columns = &lt;
          item
            Caption = 'Subject'
            Width = 80
          end
          item
            Caption = 'Start'
            Width = 80
          end
          item
            Caption = 'End'
            Width = 80
          end
          item
            Caption = 'Duration'
            Width = 80
          end
          item
            Caption = 'Location'
            Width = 80
          end
          item
            Caption = 'Body'
            Width = 80
          end&gt;
        GridLines = True
        TabOrder = 0
        ViewStyle = vsReport
      end
    end
    object TabSheet2: TTabSheet
      Caption = 'Contact'
      ImageIndex = 1
      object lvContact: TListView
        Left = 0
        Top = 0
        Width = 953
        Height = 517
        Align = alClient
        Columns = &lt;
          item
            Caption = 'First Name'
            Width = 90
          end
          item
            Caption = 'Last Name'
            Width = 90
          end
          item
            Caption = 'M Name'
            Width = 90
          end
          item
            Caption = 'Gender'
            Width = 90
          end
          item
            Caption = 'BirthDay'
            Width = 90
          end
          item
            Caption = 'Email1 Addr'
            Width = 90
          end
          item
            Caption = 'Email1 Type'
            Width = 90
          end
          item
            Caption = 'HomeTelePhoneNumber'
            Width = 90
          end&gt;
        GridLines = True
        TabOrder = 0
        ViewStyle = vsReport
      end
    end
  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

object Form1: TForm1

Left = 450

Top = 238

BorderIcons = [biSystemMenu]

BorderStyle = bsDialog

Caption = 'Outlook reader test'

ClientHeight = 604

ClientWidth = 985

Color = clBtnFace

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = False

Position = poScreenCenter

OnCreate = FormCreate

PixelsPerInch = 96

TextHeight = 13

object btnGetData: TButton

Left = 16

Top = 568

Width = 161

Height = 25

Caption = 'Get Data From Outlook'

TabOrder = 0

OnClick = btnGetDataClick

end

object PageControl1: TPageControl

Left = 8

Top = 8

Width = 961

Height = 545

ActivePage = TabSheet2

TabOrder = 1

object TabSheet1: TTabSheet

Caption = 'Appointment'

object lvCalendar: TListView

Left = 0

Top = 0

Width = 953

Height = 517

Align = alClient

Columns = <

item

Caption = 'Subject'

Width = 80

end

item

Caption = 'Start'

Width = 80

end

item

Caption = 'End'

Width = 80

end

item

Caption = 'Duration'

Width = 80

end

item

Caption = 'Location'

Width = 80

end

item

Caption = 'Body'

Width = 80

end>

GridLines = True

TabOrder = 0

ViewStyle = vsReport

end

object TabSheet2: TTabSheet

Caption = 'Contact'

ImageIndex = 1

object lvContact: TListView

Left = 0

Top = 0

Width = 953

Height = 517

Align = alClient

Columns = <

item

Caption = 'First Name'

Width = 90

end

item

Caption = 'Last Name'

Width = 90

end

item

Caption = 'M Name'

Width = 90

end

item

Caption = 'Gender'

Width = 90

end

item

Caption = 'BirthDay'

Width = 90

end

item

Caption = 'Email1 Addr'

Width = 90

end

item

Caption = 'Email1 Type'

Width = 90

end

item

Caption = 'HomeTelePhoneNumber'

Width = 90

end>

GridLines = True

TabOrder = 0

ViewStyle = vsReport

end

Delphi中使用TIdhttp模拟发送cookie

分类：Internet 阅读 (3,445) No Responses »

10月 292012

Cookie是网站存在用户本地的一些变量，用于保存一些数据以识别用户的身份或者记录用户偏好设置等。
使用smartsniff等网络截包工具查看，当执行请求时实际上是在http请求数据里加入了cookie: key1=value1; key2=value2 …这样的值，返回数据时是类似set-cookie: key1=value1这样的值。
因为我们完全可以在用TIdHttp执行网络请求的时候模拟自己的cookie值并发送到服务器端。
这里要先说明一些TIdhttp的一个属性，AllowCookies，当此值为False时允许用户发送自定义的cookie，当此值为True时，不允许用户发送自定义的cookie。
下面是一段代码：

uses StrUtils;

procedure TForm1.Button1Click(Sender: TObject);
var
  J: Integer;
  HtmlStr: string;
begin
  // 此循环用于删除原来有的cookie值
  for J := IdHTTP1.Request.CustomHeaders.Count - 1 downto 0 do begin
    if StartsText('cookie:', IdHTTP1.Request.CustomHeaders[J]) then
      IdHTTP1.Request.CustomHeaders.Delete(J);
  end;
  IdHTTP1.Request.CustomHeaders.Add('Cookie: username=bcoder' ) ;
  // 另还可用下面的方法实现，没实验过
  //IdHTTP1.Request.CustomHeaders.Values['cookie'] := 'username=bcoder';
  HtmlStr := IdHTTP1.Get('http://svn1.bcoder.com');
end;

uses StrUtils;

procedure TForm1.Button1Click(Sender: TObject);

var

J: Integer;

HtmlStr: string;

begin

// 此循环用于删除原来有的cookie值

for J := IdHTTP1.Request.CustomHeaders.Count - 1 downto 0 do begin

if StartsText('cookie:', IdHTTP1.Request.CustomHeaders[J]) then

IdHTTP1.Request.CustomHeaders.Delete(J);

end;

IdHTTP1.Request.CustomHeaders.Add('Cookie: username=bcoder' ) ;

// 另还可用下面的方法实现，没实验过

//IdHTTP1.Request.CustomHeaders.Values['cookie'] := 'username=bcoder';

HtmlStr := IdHTTP1.Get('http://svn1.bcoder.com');

end;

Delphi中Dbgrid实现全选和反选

分类：Database, Delphi 阅读 (5,225) No Responses »

10月 032012

//全选

procedure TFrameCustSelector.ToolButton1Click(Sender: TObject);
var
	OldCurrent: TBookmark;
begin
	OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;
	DBGrid1.DataSource.DataSet.DisableControls;

	DBGrid1.DataSource.DataSet.First ;
	while not DBGrid1.DataSource.DataSet.Eof do begin
		DBGrid1.SelectedRows.CurrentRowSelected := true;
		DBGrid1.DataSource.DataSet.Next;
	end;

	DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);
	DBGrid1.DataSource.DataSet.EnableControls;
end;

//全清

procedure TFrameCustSelector.ToolButton2Click(Sender: TObject);
var
	OldCurrent: TBookmark;
begin
	OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;
	DBGrid1.DataSource.DataSet.DisableControls;

	DBGrid1.DataSource.DataSet.First ;
	while not DBGrid1.DataSource.DataSet.Eof do begin
		DBGrid1.SelectedRows.CurrentRowSelected := False;
		DBGrid1.DataSource.DataSet.Next;
	end;

	DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);
	DBGrid1.DataSource.DataSet.EnableControls;
end;

//反选
procedure TFrameCustSelector.ToolButton3Click(Sender: TObject);
var
OldCurrent: TBookmark;
begin
	OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;
	DBGrid1.DataSource.DataSet.DisableControls;

	DBGrid1.DataSource.DataSet.First ;
	while not DBGrid1.DataSource.DataSet.Eof do begin
		DBGrid1.SelectedRows.CurrentRowSelected := not DBGrid1.SelectedRows.CurrentRowSelected;
		DBGrid1.DataSource.DataSet.Next;
	end;

	DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);
	DBGrid1.DataSource.DataSet.EnableControls;
end;

//全选

procedure TFrameCustSelector.ToolButton1Click(Sender: TObject);

var

OldCurrent: TBookmark;

begin

OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;

DBGrid1.DataSource.DataSet.DisableControls;

DBGrid1.DataSource.DataSet.First ;

while not DBGrid1.DataSource.DataSet.Eof do begin

DBGrid1.SelectedRows.CurrentRowSelected := true;

DBGrid1.DataSource.DataSet.Next;

end;

DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);

DBGrid1.DataSource.DataSet.EnableControls;

end;

//全清

procedure TFrameCustSelector.ToolButton2Click(Sender: TObject);

var

OldCurrent: TBookmark;

begin

OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;

DBGrid1.DataSource.DataSet.DisableControls;

DBGrid1.DataSource.DataSet.First ;

while not DBGrid1.DataSource.DataSet.Eof do begin

DBGrid1.SelectedRows.CurrentRowSelected := False;

DBGrid1.DataSource.DataSet.Next;

end;

DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);

DBGrid1.DataSource.DataSet.EnableControls;

end;

//反选

procedure TFrameCustSelector.ToolButton3Click(Sender: TObject);

var

OldCurrent: TBookmark;

begin

OldCurrent := DBGrid1.DataSource.DataSet.Bookmark;

DBGrid1.DataSource.DataSet.DisableControls;

DBGrid1.DataSource.DataSet.First ;

while not DBGrid1.DataSource.DataSet.Eof do begin

DBGrid1.SelectedRows.CurrentRowSelected := not DBGrid1.SelectedRows.CurrentRowSelected;

DBGrid1.DataSource.DataSet.Next;

end;

DBGrid1.DataSource.DataSet.GotoBookmark(OldCurrent);

DBGrid1.DataSource.DataSet.EnableControls;

end;

delphi获取MAC地址的代码

分类：Delphi, Internet 阅读 (3,977) No Responses »

10月 032012

1、通过IP取MAC地址

uses
WinSock;

Function sendarp(ipaddr:ulong;
temp:dword;
ulmacaddr:pointer;
ulmacaddrleng:pointer) : DWord; StdCall; External ‘Iphlpapi.dll’ Name ‘SendARP’;

procedure TForm1.Button1Click(Sender: TObject);
var
myip:ulong;
mymac:array[0..5] of byte;
mymaclength:ulong;
r:integer;
begin
myip:=inet_addr(PChar(‘192.168.6.180’));
mymaclength:=length(mymac);
r:=sendarp(myip,0,@mymac,@mymaclength);
label1.caption:=’errorcode:’+inttostr(r);
label2.caption:=format(‘%2.2x:%2.2x:%2.2x:%2.2x:%2.2x:%2.2x’,[mymac[0],mymac[1],mymac[2],mymac[3],mymac[4],mymac[5]]);
end;
2、取MAC地址（含多网卡）

unit Unit1;

interface

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

Const
MAX_HOSTNAME_LEN = 128; { from IPTYPES.H }
MAX_DOMAIN_NAME_LEN = 128;
MAX_SCOPE_ID_LEN = 256;
MAX_ADAPTER_NAME_LENGTH = 256;
MAX_ADAPTER_DESCRIPTION_LENGTH = 128;
MAX_ADAPTER_ADDRESS_LENGTH = 8;

Type
TIPAddressString = Array[0..4*4-1] of Char;

PIPAddrString = ^TIPAddrString;
TIPAddrString = Record
Next : PIPAddrString;
IPAddress : TIPAddressString;
IPMask : TIPAddressString;
Context : Integer;
End;

PFixedInfo = ^TFixedInfo;
TFixedInfo = Record { FIXED_INFO }
HostName : Array[0..MAX_HOSTNAME_LEN+3] of Char;
DomainName : Array[0..MAX_DOMAIN_NAME_LEN+3] of Char;
CurrentDNSServer : PIPAddrString;
DNSServerList : TIPAddrString;
NodeType : Integer;
ScopeId : Array[0..MAX_SCOPE_ID_LEN+3] of Char;
EnableRouting : Integer;
EnableProxy : Integer;
EnableDNS : Integer;
End;

PIPAdapterInfo = ^TIPAdapterInfo;
TIPAdapterInfo = Record { IP_ADAPTER_INFO }
Next : PIPAdapterInfo;
ComboIndex : Integer;
AdapterName : Array[0..MAX_ADAPTER_NAME_LENGTH+3] of Char;
Description : Array[0..MAX_ADAPTER_DESCRIPTION_LENGTH+3] of Char;
AddressLength : Integer;
Address : Array[1..MAX_ADAPTER_ADDRESS_LENGTH] of Byte;
Index : Integer;
_Type : Integer;
DHCPEnabled : Integer;
CurrentIPAddress : PIPAddrString;
IPAddressList : TIPAddrString;
GatewayList : TIPAddrString;
DHCPServer : TIPAddrString;
HaveWINS : Bool;
PrimaryWINSServer : TIPAddrString;
SecondaryWINSServer : TIPAddrString;
LeaseObtained : Integer;
LeaseExpires : Integer;
End;

type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure GetAdapterInformation;
public
{ Public declarations }
end;

var
Form1: TForm1;

Function sendarp(ipaddr:ulong;
temp:dword;
ulmacaddr:pointer;
ulmacaddrleng:pointer) : DWord; StdCall;

implementation

{$R *.dfm}

Function sendarp; External ‘Iphlpapi.dll’ Name ‘SendARP’;
Function GetAdaptersInfo(AI : PIPAdapterInfo; Var BufLen : Integer) : Integer;
StdCall; External ‘iphlpapi.dll’ Name ‘GetAdaptersInfo’;

procedure TForm1.GetAdapterInformation;
Var
AI,Work : PIPAdapterInfo;
Size : Integer;
Res : Integer;
I : Integer;

Function MACToStr(ByteArr : PByte; Len : Integer) : String;
Begin
Result := ”;
While (Len > 0) do Begin
Result := Result+IntToHex(ByteArr^,2)+’-‘;
ByteArr := Pointer(Integer(ByteArr)+SizeOf(Byte));
Dec(Len);
End;
SetLength(Result,Length(Result)-1); { remove last dash }
End;

Function GetAddrString(Addr : PIPAddrString) : String;
Begin
Result := ”;
While (Addr <> nil) do Begin
Result := Result+’A: ‘+Addr^.IPAddress+’ M: ‘+Addr^.IPMask+#13;
Addr := Addr^.Next;
End;
End;

Function TimeTToDateTimeStr(TimeT : Integer) : String;
Const UnixDateDelta = 25569; { days between 12/31/1899 and 1/1/1970 }
Var
DT : TDateTime;
TZ : TTimeZoneInformation;
Res : DWord;

Begin
If (TimeT = 0) Then Result := ”
Else Begin
{ Unix TIME_T is secs since 1/1/1970 }
DT := UnixDateDelta+(TimeT / (24*60*60)); { in UTC }
{ calculate bias }
Res := GetTimeZoneInformation(TZ);
If (Res = TIME_ZONE_ID_INVALID) Then RaiseLastWin32Error;
If (Res = TIME_ZONE_ID_STANDARD) Then Begin
DT := DT-((TZ.Bias+TZ.StandardBias) / (24*60));
Result := DateTimeToStr(DT)+’ ‘+WideCharToString(TZ.StandardName);
End
Else Begin { daylight saving time }
DT := DT-((TZ.Bias+TZ.DaylightBias) / (24*60));
Result := DateTimeToStr(DT)+’ ‘+WideCharToString(TZ.DaylightName);
End;
End;
End;

begin
Memo1.Lines.Clear;
Size := 5120;
GetMem(AI,Size);
Res := GetAdaptersInfo(AI,Size);
If (Res <> ERROR_SUCCESS) Then Begin
SetLastError(Res);
RaiseLastWin32Error;
End;
With Memo1,Lines do Begin
Work := AI;
I := 1;
Repeat
Add(”);
Add(‘Adapter ‘ + IntToStr(I));
Add(‘ ComboIndex: ‘+IntToStr(Work^.ComboIndex));
Add(‘ Adapter name: ‘+Work^.AdapterName);
Add(‘ Description: ‘+Work^.Description);
Add(‘ Adapter address: ‘+MACToStr(@Work^.Address,Work^.AddressLength));
Add(‘ Index: ‘+IntToStr(Work^.Index));
Add(‘ Type: ‘+IntToStr(Work^._Type));
Add(‘ DHCP: ‘+IntToStr(Work^.DHCPEnabled));
Add(‘ Current IP: ‘+GetAddrString(Work^.CurrentIPAddress));
Add(‘ IP addresses: ‘+GetAddrString(@Work^.IPAddressList));
Add(‘ Gateways: ‘+GetAddrString(@Work^.GatewayList));
Add(‘ DHCP servers: ‘+GetAddrString(@Work^.DHCPServer));
Add(‘ Has WINS: ‘+IntToStr(Integer(Work^.HaveWINS)));
Add(‘ Primary WINS: ‘+GetAddrString(@Work^.PrimaryWINSServer));
Add(‘ Secondary WINS: ‘+GetAddrString(@Work^.SecondaryWINSServer));
Add(‘ Lease obtained: ‘+TimeTToDateTimeStr(Work^.LeaseObtained));
Add(‘ Lease expires: ‘+TimeTToDateTimeStr(Work^.LeaseExpires));
Inc(I);
Work := Work^.Next;
Until (Work = nil);
End;
FreeMem(AI);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GetAdapterInformation;
end;

end.
方法2

uses nb30;

function NBGetAdapterAddress(a: Integer): string;
var
NCB: TNCB; // Netbios control block //NetBios控制块
ADAPTER: TADAPTERSTATUS; // Netbios adapter status//取网卡状态
LANAENUM: TLANAENUM; // Netbios lana
intIdx: Integer; // Temporary work value//临时变量
cRC: Char; // Netbios return code//NetBios返回值
strTemp: string; // Temporary string//临时变量
begin
Result := ”;

try
ZeroMemory(@NCB, SizeOf(NCB)); // Zero control blocl

NCB.ncb_command := Chr(NCBENUM); // Issue enum command
cRC := NetBios(@NCB);

NCB.ncb_buffer := @LANAENUM; // Reissue enum command
NCB.ncb_length := SizeOf(LANAENUM);
cRC := NetBios(@NCB);
if Ord(cRC) <> 0 then
exit;

ZeroMemory(@NCB, SizeOf(NCB)); // Reset adapter
NCB.ncb_command := Chr(NCBRESET);
NCB.ncb_lana_num := LANAENUM.lana[a];
cRC := NetBios(@NCB);
if Ord(cRC) <> 0 then
exit;
ZeroMemory(@NCB, SizeOf(NCB)); // Get adapter address
NCB.ncb_command := Chr(NCBASTAT);
NCB.ncb_lana_num := LANAENUM.lana[a];
StrPCopy(NCB.ncb_callname, ‘*’);
NCB.ncb_buffer := @ADAPTER;
NCB.ncb_length := SizeOf(ADAPTER);
cRC := NetBios(@NCB);

strTemp := ”; // Convert it to string
for intIdx := 0 to 5 do
strTemp := strTemp + InttoHex(Integer(ADAPTER.adapter_address[intIdx]), 2);
Result := strTemp;
finally
end;
end;

Page 1 of 2 1 2 Older Entries