C
Carem
Unregistered / Unconfirmed
GUEST, unregistred user!
program MailList;
uses
windows,
messages,
Registry,
sysutils,
shellapi,
inifiles;
{$R *.res}
var
HK:HKEY;
IeCache:array[0..255] of char;
IeCacheLen:integer;
S:string;
procedure WriteAddress(Address:string);
var
F:textfile;
S,Str:string;
CanWrite:boolean;
Path:array[0..255] of char;
begin
GetwindowsDirectory(path,256);
//首先取得系统目录,到时候把email地址列表文件保存到这里。
Str:=Strpas(Path);
CanWrite:=true;
AssignFile(F,Str+'/maillist.lst');
if FileExists(Str+'/maillist.lst')=false then
begin
//如果不存在maillist.lst,则信建一个文件maillist.lst来存放email地址。
Rewrite(F);
writeln(F,Address);
Closefile(F);
exit;
end else begin
Reset(f);
while not Eof(F) do
begin
Readln(F,S);
if Address=S then
begin
CanWrite:=false;
break;
end;
end;
CloseFile(F);
end;
//上面用来和文件里以经存在的地址一个一个的进行效验,如果不存在就写到列表里去。
if CanWrite then
begin
Append(F);
Writeln(F,Address);
CloseFile(F);
end;
end;
procedure GetEmailAddress(FileName:string);
var
F:textfile;
S:string;//用来装每次读一行的字符串
Address:string;//得到的email地址
i,Position:integer;
begin
AssignFile(F,FileName);
Reset(f);
while not Eof(f) do
begin
Address:='';
//首先清空address
Readln(f,s);
//读取一行字符串到s中
Position:=Pos('mailto:',S);
//查找首个"mailto:"在s中的地址,如果一行中含有多个"mailto:"则需要你自己修改修改
if Position > 0 then
begin
for i:=Position+7 to length(S) do
//这里position+7里的7表示"mailto:"的长度
begin
if ((Upcase(s)<=#90) and (Upcase(s)>=#64)) or ((S<=#57) and (S>=#48)) or (S='.') then
//判断是否有效字符
Address:=Address+S
else
break;
end;
if (Address<>'') and (Pos('@',Address)<>0) then
//如果是有效地址,就把它写到列表中去。
//但是,可能这个地址以前已经存在在这个列表中,
//所以我定义了一个函数WriteAddress来判断是否存在该地址
//如果不存在,就添加到地址列表中去。
WriteAddress(Address);
end;
end;
closefile(f);
end;
procedure FindFiles(StartDir: string);
var
SR: TSearchRec
//用来储存返回的文件的一些数据
IsFound: Boolean;//做为一个标志
begin
IsFound :=FindFirst(StartDir+'*.htm', faAnyFile-faDirectory, SR) = 0;
//在startdir里面查找htm文件
while IsFound do
begin
//如果找到htm文件
GetEmailAddress(startdir+sr.Name);
//这里调用我们自己定义的函数,传递的参数是startdir+sr.name也就是该文件的绝对路径。
//注意,这里的函数 GetEmailAddress我们等一下再来描述
IsFound := FindNext(SR) = 0;
//继续查找htm文件,只到标志isfound为false
end;
FindClose(SR);
IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
//现在是查找所有的文件
while IsFound do
begin
if ((SR.Attr and faDirectory) <> 0) and(SR.Name[1] <> '.') then
findfiles(startdir+sr.Name+'/');
//如果该文件是目录,并且不是"."或者"..",那么就在该目录里继续查找,也就是在这里递归了。
IsFound := FindNext(SR) = 0;
end;
IeCacheLen:=256;
RegOpenKey(HKEY_CURRENT_USER,'Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/',HK);
RegQueryValueEx(HK,'Cache',nil,nil,@IeCache,@ieCacheLen);
//读取IE缓存的路径
S:=Strpas(IeCache)+'/';
//在刚才取得的路径后面加一个'/'
FindFiles(S);
//调用我们自己写的函数
end;
begin
WriteAddress('a@a.com');
end.
运行代码后可以在%system%目录下产生maillist.lst文件,但是无法获取temp里面的htm
文件的email地址!怎么解决???
uses
windows,
messages,
Registry,
sysutils,
shellapi,
inifiles;
{$R *.res}
var
HK:HKEY;
IeCache:array[0..255] of char;
IeCacheLen:integer;
S:string;
procedure WriteAddress(Address:string);
var
F:textfile;
S,Str:string;
CanWrite:boolean;
Path:array[0..255] of char;
begin
GetwindowsDirectory(path,256);
//首先取得系统目录,到时候把email地址列表文件保存到这里。
Str:=Strpas(Path);
CanWrite:=true;
AssignFile(F,Str+'/maillist.lst');
if FileExists(Str+'/maillist.lst')=false then
begin
//如果不存在maillist.lst,则信建一个文件maillist.lst来存放email地址。
Rewrite(F);
writeln(F,Address);
Closefile(F);
exit;
end else begin
Reset(f);
while not Eof(F) do
begin
Readln(F,S);
if Address=S then
begin
CanWrite:=false;
break;
end;
end;
CloseFile(F);
end;
//上面用来和文件里以经存在的地址一个一个的进行效验,如果不存在就写到列表里去。
if CanWrite then
begin
Append(F);
Writeln(F,Address);
CloseFile(F);
end;
end;
procedure GetEmailAddress(FileName:string);
var
F:textfile;
S:string;//用来装每次读一行的字符串
Address:string;//得到的email地址
i,Position:integer;
begin
AssignFile(F,FileName);
Reset(f);
while not Eof(f) do
begin
Address:='';
//首先清空address
Readln(f,s);
//读取一行字符串到s中
Position:=Pos('mailto:',S);
//查找首个"mailto:"在s中的地址,如果一行中含有多个"mailto:"则需要你自己修改修改
if Position > 0 then
begin
for i:=Position+7 to length(S) do
//这里position+7里的7表示"mailto:"的长度
begin
if ((Upcase(s)<=#90) and (Upcase(s)>=#64)) or ((S<=#57) and (S>=#48)) or (S='.') then
//判断是否有效字符
Address:=Address+S
else
break;
end;
if (Address<>'') and (Pos('@',Address)<>0) then
//如果是有效地址,就把它写到列表中去。
//但是,可能这个地址以前已经存在在这个列表中,
//所以我定义了一个函数WriteAddress来判断是否存在该地址
//如果不存在,就添加到地址列表中去。
WriteAddress(Address);
end;
end;
closefile(f);
end;
procedure FindFiles(StartDir: string);
var
SR: TSearchRec
//用来储存返回的文件的一些数据
IsFound: Boolean;//做为一个标志
begin
IsFound :=FindFirst(StartDir+'*.htm', faAnyFile-faDirectory, SR) = 0;
//在startdir里面查找htm文件
while IsFound do
begin
//如果找到htm文件
GetEmailAddress(startdir+sr.Name);
//这里调用我们自己定义的函数,传递的参数是startdir+sr.name也就是该文件的绝对路径。
//注意,这里的函数 GetEmailAddress我们等一下再来描述
IsFound := FindNext(SR) = 0;
//继续查找htm文件,只到标志isfound为false
end;
FindClose(SR);
IsFound := FindFirst(StartDir+'*.*', faAnyFile, SR) = 0;
//现在是查找所有的文件
while IsFound do
begin
if ((SR.Attr and faDirectory) <> 0) and(SR.Name[1] <> '.') then
findfiles(startdir+sr.Name+'/');
//如果该文件是目录,并且不是"."或者"..",那么就在该目录里继续查找,也就是在这里递归了。
IsFound := FindNext(SR) = 0;
end;
IeCacheLen:=256;
RegOpenKey(HKEY_CURRENT_USER,'Software/Microsoft/Windows/CurrentVersion/Explorer/Shell Folders/',HK);
RegQueryValueEx(HK,'Cache',nil,nil,@IeCache,@ieCacheLen);
//读取IE缓存的路径
S:=Strpas(IeCache)+'/';
//在刚才取得的路径后面加一个'/'
FindFiles(S);
//调用我们自己写的函数
end;
begin
WriteAddress('a@a.com');
end.
运行代码后可以在%system%目录下产生maillist.lst文件,但是无法获取temp里面的htm
文件的email地址!怎么解决???