对于庞大的代码，串口 Message 提供了最好的追踪方法。但是很多时候，我们的代码会有重复的文件，在对照阅读的时候就会非常麻烦。一种方法是之前文章介绍过的使用 __FILE__ 的方法，唯一的问题是这个宏经常导致代码在Debug 模式下爆掉（很大原因是因为Debug模式下这个宏会加入路径信息）。因此，编写这个工具，具体的原理是：打开所有的 C 文件，查找 DEBUG宏，然后在它的字符串起始处加入 "(序号)"这样的标记。序号是由 0-9和A-Z组成的。更改代码之后，再次编译，串口输出的内容就有序号+原先的字符串，能够很方便的分析出来源。
特别注意：某些情况下可能会导致源文件的错误,这是目前分析的手法决定的。不过从我的实践来看，EDK代码不会有问题，某些工程文件可能会有1到2处标记错误，手动修改去掉即可。
这是我在某个BIOS工程上直接实验的结果：
可执行程序和完整代码下载
Delphi 的TPanel 是没有 Canavs属性的，因此无法直接在上面绘制图形。用下面的方法可以绕过限制，实现绘图的功能。
示例代码：
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls;
type
TForm2 = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.Button1Click(Sender: TObject);
var
PanelCanvas:TControlCanvas;
begin
PanelCanvas:=TControlCanvas.Create;
PanelCanvas.Control:=panel1;
with PanelCanvas do
begin
pen.Color:=clGreen;
pen.Width:=5;
MoveTo(0,0);
LineTo(Panel1.Width,Panel1.Height);
MoveTo(Panel1.Width-1,0);
LineTo(0,Panel1.Height);
end;
PanelCanvas.Free;
end;
end.
按下Button后，会在 Panel 对角线绘制直线。
代码和可执行文件下载
前几天在调试 2048 AI 程序的时候发现 Delphi 在处理 shl 超过32位时有着疑似bug的问题。
搜索一下得到如下的解答：
http://stackoverflow.com/questions/8127693/how-can-i-get-a-result-larger-than-232-from-shl
解决方法就是在做 shl 的时候做一次强制类型转换。
例如： n = Int64(2) shl 33
写一个简单的程序验证之，
program Project6;
{$APPTYPE CONSOLE}
uses
SysUtils;
begin
writeln(Format('%X',[1 shl 32]));
writeln(Format('%X',[Int64(1) shl 32]));
readln;
end.
我试验了 Delphi 7/Delphi 10/Delphi 2010都一样，但是据说 XE2 之后修正了这个潜在的问题。
根据 nneonneo 的方法完成的 Delphi 版的程序。他的程序总是用了泛型，Delphi 是从 2010 版开始支持泛型。虽然之前的版本可以使用第三方提供的泛型，比如：HouSisong大牛的DGL，但是我在实验中感觉并不好用，特别是无法直接支持
另外，我不太清楚为什么 nneonneo 要选择 map 这个类型，我从网上查阅的资料来看，这是内部有序的类型，内部使用红黑树来维持顺序，但是从他的算法来看，这里用 hash 来维持一个一对一的对应关系即可。
引入这个算法来进行剪枝后，程序速度极大提高了。
局面分数没有修改，还是使用 float，因为我觉得已经够快了。
program NeoNeo;
{$APPTYPE CONSOLE}
uses
SysUtils,windows,Generics.collections,classes,math;
const
ROW_MASK=$FFFF;
COL_MASK=$000F000F000F000F;
CPROB_THRESH_BASE = 0.0001;
CACHE_DEPTH_LIMIT=6;
SEARCH_DEPTH_LIMIT=8;
b:array[0..15] of integer=(0,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384,32768);
type
board_t=int64;
row_t=word;
get_move_func_t = function(board:board_t):integer;
T_eval_state=record
trans_table:TDictionary<board_t,single>;
cprob_thresh:single;
maxdepth:integer;
curdepth:integer;
cachehits:integer;
moves_evaled:integer;
end;
function score_tilechoose_node(var state:T_eval_state; board:board_t; cprob:single):single; forward;
function reverse_row(row:row_t):row_t; forward;
function pack_col(col:board_t):row_t; forward;
function unpack_col(row:row_t):board_t; forward;
function score_move_node(Var state:t_eval_state;board:board_t; cprob:single):single; forward;
var
row_left_table:array[0..65535] of board_t;
row_right_table:array[0..65535] of board_t;
col_up_table:array[0..65535] of board_t;
col_down_table:array[0..65535] of board_t;
line_heur_score_table:array[0..65535] of single;
row_score_table:array[0..65535] of single;
procedure init_move_tables;
var
row:LongWord;
line:array[0..3] of LongWord;
result:row_t;
i,j:integer;
begin
fillchar(row_left_table,0,sizeof(row_left_table));
fillchar(row_right_table,0,sizeof(row_right_table));
fillchar(col_up_table,0,sizeof(col_up_table));
fillchar(col_down_table,0,sizeof(col_down_table));
for row:= 0 to 65535 do
begin
line[0]:=row and $f;
line[1]:=(row shr 4) and $f;
line[2]:=(row shr 8) and $f;
line[3]:=(row shr 12) and $f;
i:=0;
while (i<3) do
begin
j:=i+1;
while (j<4) do
begin
if line[j]<>0 then
break;
inc(j);
end;
if (j=4) then break;
if (line[i]=0) then
begin
line[i]:=line[j];
line[j]:=0;
dec(i);
end
else
if (line[i]=line[j]) and (line[i]<>$f) then
begin
inc(line[i]);
line[j]:=0;
end;
inc(i);
end;
result:=(line[0]) or (line[1] shl 4) or (line[2] shl 8) or (line[3] shl 12);
row_left_table[row]:=row xor result;
row_right_table[reverse_row(row)]:=reverse_row(row) xor reverse_row(result);
col_up_table[row] := unpack_col(row) xor unpack_col(result);
col_down_table[reverse_row(row)]:=unpack_col(reverse_row(row)) xor unpack_col(reverse_row(result));
end;
end;
function execute_move_0(var board:board_t):board_t;
var
tmp:board_t;
ret:board_t;
begin
ret:=board;
tmp:=col_up_table[pack_col((board shr (4*0))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*0));
tmp:=col_up_table[pack_col((board shr (4*1))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*1));
tmp:=col_up_table[pack_col((board shr (4*2))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*2));
tmp:=col_up_table[pack_col((board shr (4*3))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*3));
Result:=ret;
end;
function execute_move_1(var board:board_t):board_t;
var
tmp:board_t;
ret:board_t;
begin
ret:=board;
tmp:=col_down_table[pack_col((board shr (4*0))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*0));
tmp:=col_down_table[pack_col((board shr (4*1))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*1));
tmp:=col_down_table[pack_col((board shr (4*2))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*2));
tmp:=col_down_table[pack_col((board shr (4*3))and $000F000F000F000F)];
ret:=ret xor (tmp shl (4*3));
Result:=ret;
end;
function execute_move_2(var board:board_t):board_t;
var
tmp:board_t;
ret:board_t;
begin
ret:=board;
tmp:=row_left_table [board shr (16*0) and $FFFF];
ret:=ret xor (tmp shl (16*0));
tmp:=row_left_table[board shr (16*1) and $FFFF];
ret:=ret xor (tmp shl (16*1));
tmp:=row_left_table[board shr (16*2) and $FFFF];
ret:=ret xor (tmp shl (16*2));
tmp:=row_left_table[board shr (16*3) and $FFFF];
ret:=ret xor (tmp shl (16*3));
Result:=ret;
end;
function execute_move_3(var board:board_t):board_t;
var
tmp:board_t;
ret:board_t;
begin
ret:=board;
tmp:=row_right_table[board shr (16*0) and $FFFF];
ret:=ret xor (tmp shl (16*0));
tmp:=row_right_table[board shr (16*1) and $FFFF];
ret:=ret xor (tmp shl (16*1));
tmp:=row_right_table[board shr (16*2) and $FFFF];
ret:=ret xor (tmp shl (16*2));
tmp:=row_right_table[board shr (16*3) and $FFFF];
ret:=ret xor (tmp shl (16*3));
Result:=ret;
end;
function pack_col(col:board_t):row_t;
begin
Result:=col or (col shr 12) or (col shr 24) or (col shr 36);
end;
function unpack_col(row:row_t):board_t;
var
tmp:board_t;
begin
tmp:=row;
Result:=(tmp or (tmp shl 12) or (tmp shl 24) or (tmp shl 36)) and COL_MASK;
end;
procedure print_board(board:board_t);
var
i:integer;
begin
for i := 0 to 3 do
begin
writeln(format('%4d %4d %4d %4d',
[b[board and $f],
b[board shr 4 and $f],
b[board shr 8 and $f],
b[board shr 12 and $f]]));
board:=board shr 16;
end;
end;
function reverse_row(row:row_t):row_t;
begin
Result:=((row shr 12) or ((row shr 4) and $F0) or ((row shl 4) and $0F00) or (row shl 12));
end;
function execute_move(move:integer;board:board_t):Board_t;
begin
case move of
0://up
begin
Result:=execute_move_0(board);
end;
1://down
begin
Result:=execute_move_1(Board);
end;
2://left
begin
Result:=execute_move_2(board);
end;
3://right
begin
Result:=execute_move_3(Board);
end;
else
Result:=0;
end;
end;
function get_max_rank(board:board_t):integer;
var
maxrank,k:integer;
begin
maxrank:=0;
while board<>0 do
begin
k:=board and $f;
if k>maxrank then maxrank:=k;
board:=board shr 4;
end;
Result:=maxrank;
end;
procedure init_score_tables;
var
row:Longword;
i,maxi:integer;
heur_score:single;
score:single;
line:array[0..3] of LongWord;
rank,maxrank:LongWord;
begin
fillchar(line_heur_score_table,0,sizeof(line_heur_score_table));
fillchar(row_score_table,0,sizeof(row_score_table));
for row:= 0 to 65535 do
begin
line[0]:=row and $f;
line[1]:=(row shr 4) and $f;
line[2]:=(row shr 8) and $f;
line[3]:=(row shr 12) and $f;
heur_score:=0;
score:=0;
for i := 0 to 3 do
begin
rank:=line[i];
if (rank=0) then
begin
heur_score:=heur_score+10000;
end
else
if (rank>=2) then
begin
score:=score+(rank-1)*power(2,rank);
end;
end;
maxi:=0;
maxrank:=0;
for i := 0 to 3 do
begin
rank:=line[i];
if (rank>maxrank) then
begin
maxrank:=rank;
maxi:=i;
end;
end;
if (maxi=0) or (maxi=3) then
heur_score:=heur_score+20000;
for i := 1 to 3 do
if (line[i]=line[i-1]+1) or (line[i]=line[i-1]-1) then
heur_score:=heur_score+1000;
if (line[0]<line[1]) and (line[1]<line[2]) and (line[2]<line[3]) then
heur_score:=heur_score+10000;
if (line[0]>line[1]) and (line[1]>line[2]) and (line[2]>line[3]) then
heur_score:=heur_score+10000;
row_score_table[row]:=score;
line_heur_score_table[row]:=heur_score;
end;
end;
{
function score_board(board:board_t;tbl):single;
begin
Result:=(tbl[board and row_mask])+
(tbl[board shr 16 and row_mask])+
(tbl[board shr 32 and row_mask])+
(tbl[board shr 48 and row_mask]);
end;
function score_col_board(board:board_t;tbl):single;
begin
Result:=(tbl[pack_col[board and col_mask]])+
(tbl[pack_col[board shr 4 and col_mask])+
(tbl[pack_col[board shr 8 and col_mask])+
(tbl[pack_col[board shr 12 and col_mask]);
end;
}
function score_heur_board(board:board_t):single;
begin
Result:=(line_heur_score_table[board and row_mask])+
(line_heur_score_table[board shr 16 and row_mask])+
(line_heur_score_table[board shr 32 and row_mask])+
(line_heur_score_table[board shr 48 and row_mask])+
(line_heur_score_table[pack_col(board and col_mask)])+
(line_heur_score_table[pack_col(board shr 4 and col_mask)])+
(line_heur_score_table[pack_col(board shr 8 and col_mask)])+
(line_heur_score_table[pack_col(board shr 12 and col_mask)])+100000;
end;
function score_board(board:board_t):single;
begin
result:=(row_score_table[board and row_mask])+
(row_score_table[(board shr 16) and row_mask] )+
(row_score_table[(board shr 32) and row_mask])+
(row_score_table[(board shr 48) and row_mask]);
end;
function score_tilechoose_node(var state:T_eval_state; board:board_t; cprob:single):single;
var
res:single;
num_open,i:integer;
begin
res:=0;
num_open:=0;
for i:=0 to 15 do
begin
if (board shr (4*i) and $f)=0 then
inc(num_open);
end;
cprob:=cprob /num_open;
for i := 0 to 15 do
begin
if ((board shr (4*i)) and $f =0) then
begin
res:=res+score_move_node(state,board or (Int64(1) shl (4*i)) ,cprob *0.9) *0.9;
res:=res+score_move_node(state,board or (Int64(2) shl (4*i)),cprob *0.1) *0.1;
end;
end;
Result:=Res / num_open;
end;
function score_move_node(Var state:t_eval_state;board:board_t; cprob:single):single;
var
move:integer;
best:single;
res:single;
newboard:board_t;
begin
if (cprob<state.cprob_thresh) or (state.curdepth >= SEARCH_DEPTH_LIMIT) then
begin
if (state.curdepth > state.curdepth) then
begin
state.maxdepth:=state.curdepth;
end;
Result:=score_heur_board(board);
exit;
end;
if (state.curdepth < CACHE_DEPTH_LIMIT) then
begin
if state.trans_table.ContainsKey(board) then
begin
inc(state.cachehits,1);
Result:=state.trans_table[board];
exit;
end;
end;
best:=0;
inc(state.curdepth);
for move := 0 to 3 do
begin
newboard:=execute_move(move,board);
inc(state.moves_evaled);
if (board = newboard) then
continue;
res:=score_tilechoose_node(state,newboard,cprob);
if res > best then
best:=res;
end;
dec(state.curdepth);
if state.curdepth < CACHE_DEPTH_LIMIT then
begin
if state.trans_table.ContainsKey(board) then
begin
state.trans_table[board]:=best;
end
else
state.trans_table.Add(board,best);
end;
result:=best;
end;
function t_score_toplevel_move(var state:t_eval_state;board:board_t;move:integer):single;
var
newboard:board_t;
begin
newboard:=execute_move(move,board);
if board=newboard then
begin
Result:=0;
exit;
end;
state.cprob_thresh:=CPROB_THRESH_BASE;
Result:=score_tilechoose_node(state,newboard,1)+1e-6;
end;
function score_toplevel_move(board:board_t; move:integer):single;
var
res:single;
start,finish:DWORD;
state:t_eval_state;
begin
state.trans_table:=TDictionary<board_t,single>.Create;
state.cprob_thresh:=0;
state.maxdepth:=0;
state.curdepth:=0;
state.cachehits:=0;
state.moves_evaled:=0;
start:=GetTickCount;
res:=t_score_toplevel_move(state,board,move);
finish:=GetTickCount;
writeln(format('Move %d: result %f: eval %d moves. (%d Cache hits)',
[move,res,state.moves_evaled,state.cachehits])+'in '+IntToStr(Finish-Start)+' ms');
state.trans_table.Free;
result:=res;
end;
function find_best_move(board:board_t):integer;
var
move:integer;
best:single;
bestmove:integer;
res:single;
begin
best:=0;
bestmove:=-1;
print_board(board);
writeln(format('Current scores: heur %.0f, actual %.0f',[score_heur_board(board),score_board(board)]));
for move := 0 to 3 do
begin
res:=score_toplevel_move(board,move);
if (res>best) then
begin
best:=res;
bestmove:=move;
end;
end;
Result:=bestmove;
end;
function draw_tile:integer;
begin
if Random(9)=0 then Result:=2
else Result:=1;
end;
function insert_tile_rand(board:board_t;tile:integer):board_t;
var
num_open:integer;
i,index:integer;
tmp:board_t;
begin
num_open:=0;
for i := 0 to 15 do
if (board shr (4*i) and $f)=0 then
begin
inc(num_open)
end;
if num_open =0 then
begin
writeln('insert_tile_rand:no open spots!');
Result:= board;
exit;
end;
index:=random(num_open);
for i := 0 to 15 do
begin
if ((board shr (4*i))and $f)<>0 then
continue;
if (index=0) then
begin
tmp:=tile;
board:=board or (tmp shl (4 *i));
break;
end;
dec(index);
end;
Result:=board;
end;
function initial_board:board_t;
var
board:board_t;
i:integer;
begin
//randomize;
board:=0;
for i := 0 to 1 do
board:=insert_tile_rand(board,draw_tile);
Result:=board;
end;
procedure play_game(get_move:get_move_func_t);
var
board:board_t;
moveno:integer;
scorepenalty:integer;
move:integer;
newboard:board_t;
tile:integer;
begin
board:=initial_board;
moveno:=0;
scorepenalty:=0;
while True do
begin
move:=0;
while move<4 do
begin
if execute_move(move,board)<>board then
break;
inc(move);
end;
if move=4 then break;
inc(moveno);
writeln(format('Move %d , current score=%.0f, %d',[moveno,score_board(board)-scorepenalty,scorepenalty]));
move:=get_move(board);
if (move < 0) then break;
newboard:=execute_move(move,board);
if (newboard=board) then
begin
writeln('Illegal move!');
dec(moveno);
continue;
end;
tile:=draw_tile;
if tile=2 then inc(scorepenalty,4);
board:=insert_tile_rand(newboard,tile);
writeln;
end;
print_board(board);
writeln(Format('Game Over. Your score is %.0f. The hightest rank you achieved was %d.',[score_board(board)-scorepenalty,get_max_rank(board)]));
end;
//Main
begin
init_move_tables;
init_score_tables;
play_game (find_best_move);
readln;
end.
没有运行完，中途暂停截图：
上面的程序中使用的是伪随机数，这样可以方便比较和评估。如果需要测试更多局面，请查找并打开 randomize 。
写完程序的一点感受：时代在变化，算法依然非常重要，技术的进步使得人们可以更加关注于该用什么而不是如何实现。
代码下载
www.lab-z.com
Zoologist
2014-4-26
一个用于分离GOP和VBT文件的工具
这个工具是用来分离Intel Baytrail公版BIOS中的VBT和GOP文件的。其中的GOP是传统意义上的VBIOS，VBT文件是他的配置文件。在之前，配置
信息通常会写入到VBIOS中，但是在BayTrail上他们是分开独立的。
用法：
BTYGVS [文件名]
比如：BTYGVS IFWI_2013_10_01 即可在当前目录下生成这个BIOS中
包括的GOP和VBT。
下载
前一段时间研究了一下 LZ77 算法，后来又看了一下它的改进版本 LZMA。虽然基本思想已经完全领悟，但是要想具体写出代码还是很有难度，直接研究实现算法又被很多细节阻挡。好在时代不同了，虽然你无法写出具体代码，但是也有现成的库供你调用。
目前开源的比较好用的就是 7-zip 了，这里可以看到中文的介绍：http://sparanoid.com/lab/7z/
同时他还提供了 SDK 供以调用 http://sparanoid.com/lab/7z/sdk.html 。
对于 Delphi 的用户，能够使用的 SDK 在 http://www.birtles.org.uk/programming/ 这里可以下载到。是原生的 Delphi 编写无需第三方库。为了测试我编写了一个Console模式下压缩的小程序，并且在程序中我避免使用这个库内部定义的 Stream 而是直接使用 TMemoryStream。
program LZMAencoder;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils, Windows, Classes,ULZMAEncoder,ULZMACommon;
var
FInput,Foutput:TMemoryStream; //直接使用基础的 MemoryStream
encoder:TLZMAEncoder; //编码器
i:integer; //算法方面的要求，最后要补零。具体请查看LZ77描述
begin
FInput:=TMemoryStream.Create; //创建和读取一个文件作为压缩的源
FInput.LoadFromFile('C:\Users\Administrator\Documents\RAD Studio\Projects\LZMAEncoder\original.txt');
encoder:=TLZMAEncoder.Create;
encoder.SetAlgorithm(2); //设置压缩比，看代码似乎没有真正实现
encoder.SetDictionarySize(1 shl 23); //设置字典大小
encoder.SeNumFastBytes(128); //不知道这个是什么
encoder.SetMatchFinder(1); //找到1个匹配
encoder.SetLcLpPb(3, 0, 2); //应该是LZ77算法用到的几个参数
encoder.SetEndMarkerMode(false); //是否写入流结束标志。因为压缩之后的头上有大小
//所以这里完全不用写入
FOutput:=TMemoryStream.Create;
encoder.WriteCoderProperties(FOutput); //写入头信息
for i := 0 to 7 do
WriteByte(FOutput,(FInput.Size shr (8 * i)) and $FF); //补全完整流
encoder.Code(Finput, FOutput, -1, -1); //解压过程
encoder.free;
FOutput.SaveToFile('C:\Users\Administrator\Documents\RAD Studio\Projects\LZMAEncoder\result.7z');
FOutput.Destroy;
Finput.Destroy;
readln;
end.
压缩结果可以直接用 7-zip 打开（WinZip, WinRar不行）。
原始的 LZMA 代码 LZMA.442b
本文提到的例子：LZMAEncoder
根据 http://delphi.cjcsoft.net/viewthread.php?tid=48860 文章内容，将类似 \\?\USB#Vid_4146&Pid_d2b5#0005050400044#{a5dcbf10-6530-11d2-901f-00c04fb951ed} 转化为更易读的类型，例如
USB Inserted
Device Type = USB Mass Storage Device
Driver Name = Disk drive
Friendly Name = I0MEGA UMni1GB*IOM2J4 USB Device
之前《关于监视插入U盘的问题（1）》中给出了接收 WM_DEVICECHANGE 消息的方法。从资料中可以看出，直接处理这个消息能够获得当前系统发生变化的盘符，但是无法处理未产生盘符变化（未分区或者其他USB设备）。对于这样的问题，可以使用RegisterDeviceNotification来向系统注册一个回调函数，并且设置好只通知USB设备变化，通过这样的方法能够取得发生变化的USB设备的信息，之后再通过查询注册表对照出更易读的信息。
文章还指出这样的转换是通过读取注册表来完成的。
我编写了如下例子，实践证明这个程序工作很好。除了普通的U盘，我还地尝试了一个 USB2UART 的 Cable，可以看出工作正常。
测试环境为 Win7+Delphi10，不需要管理员权限运行程序即可。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,MahUSB;
type
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
FUsb : TUsbClass;
procedure UsbIN(ASender : TObject; const ADevType,ADriverName,
AFriendlyName : string);
procedure UsbOUT(ASender : TObject; const ADevType,ADriverName,
AFriendlyName : string);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
FreeAndNil(FUsb);
end;
procedure TForm1.FormShow(Sender: TObject);
begin
FUsb := TUsbClass.Create;
FUsb.OnUsbInsertion := UsbIN;
FUsb.OnUsbRemoval := UsbOUT;
end;
procedure TForm1.UsbIN(ASender : TObject; const ADevType,ADriverName,
AFriendlyName : string);
begin
showmessage('USB Inserted - Device Type = ' + ADevType + #13#10 +
'Driver Name = ' + ADriverName + #13+#10 +
'Friendly Name = ' + AFriendlyName);
end;
procedure TForm1.UsbOUT(ASender : TObject; const ADevType,ADriverName,
AFriendlyName : string);
begin
showmessage('USB Removed - Device Type = ' + ADevType + #13#10 +
'Driver Name = ' + ADriverName + #13+#10 +
'Friendly Name = ' + AFriendlyName);
end;
end.
============================================================================================
unit MahUSB;
interface
uses Windows, Messages, SysUtils, Classes, Registry, Masks;
type
{ Event Types }
TOnUsbChangeEvent = procedure(AObject : TObject;
const ADevType,ADriverName,
AFriendlyName : string) of object;
{ USB Class }
TUsbClass = class(TObject)
private
FHandle : HWND;
FOnUsbRemoval,
FOnUsbInsertion : TOnUsbChangeEvent;
procedure GetUsbInfo(const ADeviceString : string;
out ADevType,ADriverDesc,
AFriendlyName : string);
procedure WinMethod(var AMessage : TMessage);
procedure RegisterUsbHandler;
procedure WMDeviceChange(var AMessage : TMessage);
public
constructor Create;
destructor Destroy; override;
property OnUsbInsertion : TOnUsbChangeEvent read FOnUsbInsertion
write FOnUsbInsertion;
property OnUsbRemoval : TOnUsbChangeEvent read FOnUsbRemoval
write FOnUsbRemoval;
end;
// -----------------------------------------------------------------------------
implementation
type
// Win API Definitions
PDevBroadcastDeviceInterface = ^DEV_BROADCAST_DEVICEINTERFACE;
DEV_BROADCAST_DEVICEINTERFACE = record
dbcc_size : DWORD;
dbcc_devicetype : DWORD;
dbcc_reserved : DWORD;
dbcc_classguid : TGUID;
dbcc_name : char;
end;
const
// Miscellaneous
GUID_DEVINTF_USB_DEVICE : TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
USB_INTERFACE = $00000005; // Device interface class
USB_INSERTION = $8000; // System detected a new device
USB_REMOVAL = $8004; // Device is gone
// Registry Keys
USBKEY = 'SYSTEM\CurrentControlSet\Enum\USB\%s\%s';
USBSTORKEY = 'SYSTEM\CurrentControlSet\Enum\USBSTOR';
SUBKEY1 = USBSTORKEY + '\%s';
SUBKEY2 = SUBKEY1 + '\%s';
constructor TUsbClass.Create;
begin
inherited Create;
FHandle := AllocateHWnd(WinMethod);
RegisterUsbHandler;
end;
destructor TUsbClass.Destroy;
begin
DeallocateHWnd(FHandle);
inherited Destroy;
end;
procedure TUsbClass.GetUsbInfo(const ADeviceString : string;
out ADevType,ADriverDesc,
AFriendlyName : string);
var sWork,sKey1,sKey2 : string;
oKeys,oSubKeys : TStringList;
oReg : TRegistry;
i,ii : integer;
bFound : boolean;
begin
ADevType := '';
ADriverDesc := '';
AFriendlyName := '';
if ADeviceString<>'' then begin
bFound := false;
oReg := TRegistry.Create;
oReg.RootKey := HKEY_LOCAL_MACHINE;
// Extract the portions of the string we need for registry. eg.
// \\?\USB#Vid_4146&Pid_d2b5#0005050400044#{a5dcbf10- ..... -54334fb951ed}
// We need sKey1='Vid_4146&Pid_d2b5' and sKey2='0005050400044'
sWork := copy(ADeviceString,pos('#',ADeviceString) + 1,1026);
sKey1 := copy(sWork,1,pos('#',sWork) - 1);
sWork := copy(sWork,pos('#',sWork) + 1,1026);
sKey2 := copy(sWork,1,pos('#',sWork) - 1);
// Get the Device type description from \USB key
if oReg.OpenKeyReadOnly(Format(USBKEY,[skey1,sKey2])) then begin
ADevType := oReg.ReadString('DeviceDesc');
oReg.CloseKey;
oKeys := TStringList.Create;
oSubKeys := TStringList.Create;
// Get list of keys in \USBSTOR and enumerate each key
// for a key that matches our sKey2='0005050400044'
// NOTE : The entry we are looking for normally has '&0'
// appended to it eg. '0005050400044&0'
if oReg.OpenKeyReadOnly(USBSTORKEY) then begin
oReg.GetKeyNames(oKeys);
oReg.CloseKey;
// Iterate through list to find our sKey2
for i := 0 to oKeys.Count - 1 do begin
if oReg.OpenKeyReadOnly(Format(SUBKEY1,[oKeys[i]])) then begin
oReg.GetKeyNames(oSubKeys);
oReg.CloseKey;
for ii := 0 to oSubKeys.Count - 1 do begin
if MatchesMask(oSubKeys[ii],sKey2 + '*') then begin
// Got a match?, get the actual desc and friendly name
if oReg.OpenKeyReadOnly(Format(SUBKEY2,[oKeys[i],
oSubKeys[ii]])) then begin
ADriverDesc := oReg.ReadString('DeviceDesc');
AFriendlyName := oReg.ReadString('FriendlyName');
oReg.CloseKey;
end;
bFound := true;
end;
end;
end;
if bFound then break;
end;
end;
FreeAndNil(oKeys);
FreeAndNil(oSubKeys);
end;
FreeAndNil(oReg);
end;
end;
procedure TUsbClass.WMDeviceChange(var AMessage : TMessage);
var iDevType : integer;
sDevString,sDevType,
sDriverName,sFriendlyName : string;
pData : PDevBroadcastDeviceInterface;
begin
if (AMessage.wParam = USB_INSERTION) or
(AMessage.wParam = USB_REMOVAL) then begin
pData := PDevBroadcastDeviceInterface(AMessage.LParam);
iDevType := pData^.dbcc_devicetype;
// Is it a USB Interface Device ?
if iDevType = USB_INTERFACE then begin
sDevString := PChar(@pData^.dbcc_name);
GetUsbInfo(sDevString,sDevType,sDriverName,sFriendlyName);
// Trigger Events if assigned
if (AMessage.wParam = USB_INSERTION) and
Assigned(FOnUsbInsertion) then
FOnUsbInsertion(self,sDevType,sDriverName,sFriendlyName);
if (AMessage.wParam = USB_REMOVAL) and
Assigned(FOnUsbRemoval) then
FOnUsbRemoval(self,sDevType,sDriverName,sFriendlyName);
end;
end;
end;
procedure TUsbClass.WinMethod(var AMessage : TMessage);
begin
if (AMessage.Msg = WM_DEVICECHANGE) then
WMDeviceChange(AMessage)
else
AMessage.Result := DefWindowProc(FHandle,AMessage.Msg,
AMessage.wParam,AMessage.lParam);
end;
procedure TUsbClass.RegisterUsbHandler;
var rDbi : DEV_BROADCAST_DEVICEINTERFACE;
iSize : integer;
begin
iSize := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
ZeroMemory(@rDbi,iSize);
rDbi.dbcc_size := iSize;
rDbi.dbcc_devicetype := USB_INTERFACE;
rDbi.dbcc_reserved := 0;
rDbi.dbcc_classguid := GUID_DEVINTF_USB_DEVICE;
rDbi.dbcc_name := #0;
RegisterDeviceNotification(FHandle,@rDbi,DEVICE_NOTIFY_WINDOW_HANDLE);
end;
end.
