Unit smtp_connections; // ---------------------------------------- // Definition Unit // ------------------------------------------- Interfaces Classes , StdCtrls; const WinSock = 'wsock32.dll'; Internet = 2; Stream = 1; fIoNbRead = $ 4004667F; WinSMTP = $ 0001; LinuxSMTP = $ 0002; type TWSAData = packed record wVersion: Word; wHighVersion: Word; szDescription: array [ 0..256] of char; szsystemStatus: array [0..128] of char; imaxsockets: word; imax indepdg: word; lpvendorinfo: pchar; end; phost = ^ thost; thove = packed record name: pchame; aliases: ^ Pchar; addr: smallint; addr: ^ POINTER; END; TSOCKADDR = Packed Record Family: Word; Port: Word; AddR: longint; zeros: array [0..7] of byte; end; function wsastartup Version: word; Var Data: TwsaData): integer; stdcall; far; external winsock; function socket (Family, Kind, Protocol: integer): integer; stdcall; far; external winsock; function shutdown (socket, How: Integer): integer; stdcall; far; external winsock; function closesocket (socket: Integer): integer; stdcall; far; external winsock; function WSACleanup: integer; stdcall; far; external winsock; function bind (Socket: Integer; Var SockAddr: TSockAddr; AddrLen: integer): integer ; stdcall; far; external winsock; function listen (socket, flags: Integer): integer; stdcall; far; external winsock; function connect (socket: Integer; Var sockAddr: TSockAddr; AddrLen: integer): integer; stdcall; far; external winsock; function accept (socket: Integer; Var sockAddr: TSockAddr; Var AddrLen: Integer): integer; stdcall; far; external winsock; function WSAGetLastError: integer; stdcall; far; external winsock; function recv (socket: integer; data : pchar;
datalen, flags: integer): integer; stdcall; far; external winsock; function send (socket: integer; var data; datalen, flags: integer): integer; stdcall; far; external winsock; function gethostbyname (HostName: PChar): PHost; stdcall; far; external winsock; function WSAIsBlocking: boolean; stdcall; far; external winsock; function WSACancelBlockingCall: integer; stdcall; far; external winsock; function ioctlsocket (socket: integer; cmd: Longint; var arg: longint): Integer; stdcall; far; external winsock; function gethostname (name: pchar; size: integer): integer; stdcall; far; external winsock; procedure _authSendMail (MailServer, uname, upass, mFrom, mFromName, mToName, Subject: string; mto , mbody: TStringList); function ConnectServer (mhost: string; mport: integer): integer; function ConnectServerwin (mhost: string; mport: integer): integer; function DisConnectServer: integer; function Stat: string; function SendCommand (Command: String : String; Function Senddata: String; Function Sendcommandwin (Command: String): String; Fu nction ReadCommand: string; function encryptB64 (s: string): string; var mconnHandle: Integer; mFin, mFOut: Textfile; EofSock: Boolean; mactive: Boolean; mSMTPErrCode: Integer; mSMTPErrText: string; mMemo: TMemo; implementationuses SysUtils, Sockets , IdBaseComponent, IdCoder, IdCoder3to4, IdCoderMIME, IniFiles, Unit1; var mClient: TTcpClient; procedure _authSendMail (MailServer, uname, upass, mFrom, mFromName, mToName, Subject: string; mto, mbody: TStringList); var tmpstr: string; cnt : Integer; mstrlist: TStrings; RecipientCount: Integer; begin if ConnectServerWin (Mailserver, 25) = 250 then begin Sendcommandwin ( 'AUTH LOGIN'); SendcommandWin (encryptB64 (uname)); SendcommandWin (encryptB64 (upass));
Sendcommandwin ('mail from:' mfrom); for cnt: = 0 to mto.count - 1 do sendcommandwin ('RCPT TO:' MTO [CNT]); SendcommandWin ('data'); Senddata ('Subject:' Subject); Senddata ('from: "' mfromname " <' mfrom '>); sendData ('to:' mtoname); senddata ('mime-version: 1.0'); sendData (' Content-type: Multipart / Related; Boundary = "esales-Order"; sendata ('type = "text / html"); senddata (' '); senddata (' - esales-order '); sendData ('Content-Type: TEXT / HTML;'); Senddata ('Charset = "ISO-8859-9"); Senddata (' Content-Transfer-Encoding: Quoted-Printable '); Senddata ('); for CNT: = 0 to Mbody.count - 1 do senddata; senddata (''); sendData ('- esales-order--'); sendData (''); msmtperrtext: = sendcommand (CRLF '.' Crlf); try msmtperrcode: = start (COPY (MSMTperrtext, 1, 3)); Except end; sendData ('quit'); disconnectServer; end; end; function stat: string; var s: string; Begin s: = readc ommand; Result: = s; end; function EchoCommand (Command: string): string; begin SendCommand (Command); Result: = ReadCommand; end; function ReadCommand: string; var tmp: string; begin repeat ReadLn (mfin, tmp) ; If Assigned (MMemo) THEN MMEMO.LINES.ADD (TMP); Until (tmp) <4) OR (TMP [4] <> '-'); Result: = TMPEND; Function Senddata (Command: String) : String; Begin Writeln (Mfout, Command); END;
Function SendCommand: String; Begin Writeln (Mfout, Command); Result: = Stat; End; Function Sendcommandwin (Command: String): string; begin Writeln (Mfout, Command # 13); Result: = Stat (Source: String; Number: integer): string; var A: integer; begin result: = '; for A: = Length (Trim (Trim (Source)) To number do results: = result ' ' End; function iptolong (ip: string): longint; var x, i: byte; ipx: array [0..3] of byte; v: integer; begin result: = 0; longint (ipx): = 0; i: = 0; for x: = 1 to length (ip) DO if IP [x] = '.' Then Begin INC (i); if i = 4 THEN EXIT; ELSE BEGIN if Not (IP [x] in ['0' .. '9']) THEN EXIT; V: = IPX [i] * 10 ORD (IP [x]) - ORD ('0'); if v> 255 Then EXIT; IPX [i] : = V; End; Result: = longint (ipx); end; function hosttolong (Ahost: string): longint; var host: phost; begin result: = iptolong (ahost); if result = 0 Then Begin Host: = gethostbyname (Pchar (ahost)); if host <> nil the result: = lon Gint (host ^ .addr ^^); end; end; function longtoip (long: longint): string; var ipx: array [0..3] of byte; i: byte; begin longint (ipx): = long; Result: = '; for i: = 0 to 3 do results: = Result INTOSTR (IPX [I]) '. '; Setlength (Result, Length (Result) - 1); end; procedure disconnect (socket: INTEGER); Begin Shutdown (Socket, 1); CloseSocket; End; Function Call Server (Server: String; Port: Word): Integer; Var SockAddr: TsockAddr; Begin Result: = Socket (Internet, Stream, 0); If Result = -1 Then EXIT; Fillchar (SockAddr), 0);
SockAddr.Family: = Internet; SockAddr.Port: = swap (Port); SockAddr.Addr: = HostToLong (Server); if Connect (Result, SockAddr, SizeOf (SockAddr)) <> 0 then begin Disconnect (Result); Result : = -1; End; End; Function OutputSock (VAR f: TtextRec): Integer; Far; Begin IF.BUFPOS <> 0 THEN Begin Send (F.Handle, F.BUFPTR ^, F.BUFPOS, 0); F.BUFPOS: = 0; End; Result: = 0; End; Function INPUTSOCK (VAR f: TtextRec): Integer; Far; Var size: longint; begin f.bufend: = 0; F.BUFPOS: = 0; Result : = 0; Repeat IF (IOCTLSOCKET (F.Handle, Fionbread, Size) <0) THEN BEGIN EOFSOCK: = true; exit; end; untric (size> = 0); f.bufend: = RECV (F.Handle, F.BUFPTR, F.BUFSIZE, 0); EOFSOCK: = (f.bufend = 0); End; Function CloseSock (VAR F: TTEXTREC): Integer; Far; Begin Disconnect (f.handle: = -1; Result: = 0; End; Function OpenSock (var f: ttextrec): integer; far; begin if f.mode = false; f.buffpos: = 0; f.bufend: = 0 F.inoutfunc: = @INPUTSOCK; F.FLUSHFUNC: = NIL; END ELSE BEGIN F.MODE: = fmoutput; f.inoutfunc: = @outputSock; f.flushfunc: = @outputsock; end; f.closefunc: = @closeSock; result: = 0 ; end; procedure AssignCrtSock (Socket: integer; Var Input, Output: TextFile); begin with TTextRec (Input) do begin Handle: = Socket; Mode: = fmClosed; BufSize: = SizeOf (Buffer); bufPtr: = @Buffer; OpenFunc: @opensock; end; with ttextrec (output) do begin handle: = socket; mode: = fmclosed; buffs: = sizeof (buffer); bufptr: = @buffer;
OpenFunc: = @opensock; end; reset (input); RewRite (OUTPUT); END; Function ConnectServer (Mhost: String; Mport: Integer): Integer; var TMP: String; begin mclient: = ttclient.create (nil); mClient.RemoteHost: = mhost; mClient.RemotePort: = IntToStr (mport); mClient.Connect; mconnhandle: = callserver (mhost, mport); if (mconnHandle <> - 1) then begin AssignCrtSock (mconnHandle, mFin, MFout); TMP: = stat; tmp: = sendcommand ('helo beln.com.tr'); if Copy (TMP, 1, 3) = '250' Then Begin Result: = STRTOINT (COPY (TMP, 1, 3)); end; end; end; function ConnectServerWin (mhost: string; mport: Integer): Integer; var tmp: string; begin mClient: = TTcpClient.Create (nil); mClient.RemoteHost: = mhost; mClient.RemotePort: = IntToStr ( MPORT); MCLIENT.CONNECT; MCONNHANDLE: = Call Server (MCONNHLE <> - 1) The begin AssignCRTSOCK (Mconnhandle, Mfin, Mfout); TMP: = Stat; TMP: = Sendcommandwin ('Hellona. COM.TR '); if Copy (TMP, 1, 3) =' 250 'Then BEG in Result: = StrToInt (Copy (tmp, 1, 3)); end; end; end; function DisConnectServer: Integer; begin closesocket (mconnhandle); mClient.Disconnect; mclient.Free; end; function encryptB64 (s: string) : String; var hash1: tidencodermime; p: string; begin if s <> '' Then Begin Hash1: = TIDENCODERMIME.CREATE (NIL); p: = hash1.encode (s); hash1.free; end; result: = P; end; end .///-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- // How to use the definition related unit // ------------------------------------- ---- Unit Unit1; InterfaceUses Windows, Messages, Sysutils, Classes, Graphics, Controls, Forms, Dialogs, Stdctrls
