Enviar EMail ( Sin Componentes )

[n3ck]

Me doy cuenta que mucha gente pregunta como enviar un EMail.
Asi que Aqui les dejo la EMail Unit que reduce enviar un email a una sola funcion sin utilizar un solo componente.
Espero les sea util.

--------------------------------------------------------------
Lo se, se puede simplificar mucho mas pero asi requiero la funcion
para mis programas
--------------------------------------------------------------

  UNIT EMail;
  
  INTERFACE
  
  USES
  Windows,WinSock;
  
  function SendEmail(SMTP, Asunto, Mensaje, Para, De, Archivo : AnsiString) : Boolean;
  
  IMPLEMENTATION
  
  CONST
  CRLF = #13#10;
  cBase64Codec = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
  
  TYPE
  Triple = ARRAY[1..3] OF BYTE;
  Quad = ARRAY[1..4] OF BYTE;
  
  VAR
  SMTPServer : STRING;
  SMTPAcc : STRING;
  Sock : TSocket;
  FileBuf : AnsiString;
  
  FUNCTION NameToIP(HostName:STRING) : STRING;
  LABEL Abort;
  TYPE
  TAPInAddr = ARRAY[0..100] OF PInAddr;
  PAPInAddr =^TAPInAddr;
  VAR
  WSAData : TWSAData;
  HostEntPtr : PHostEnt;
  pptr : PAPInAddr;
  I : Integer;
  BEGIN
  Result:='';
  WSAStartUp($101,WSAData);
  TRY
  HostEntPtr:=GetHostByName(PChar(HostName));
  IF HostEntPtr=NIL THEN GOTO Abort;
  pptr:=PAPInAddr(HostEntPtr^.h_addr_list);
  I:=0;
  WHILE pptr^[i]<>NIL DO BEGIN
  IF HostName='' THEN BEGIN
  IF(Pos('169',inet_ntoa(pptr^[i]^))<>1)AND(Pos('192',inet_ntoa(pptr^[i]^))<>1) THEN BEGIN
  Result:=inet_ntoa(pptr^[i]^);
  GOTO Abort;
  END;
  END ELSE RESULT:=(inet_ntoa(pptr^[i]^));
  Inc(I);
  END;
  Abort:
  EXCEPT
  END;
  WSACleanUp();
  END;
  
  FUNCTION Codeb64(Count:Byte;T:Triple) : STRING;
  VAR
  Q : Quad;
  Strg : STRING;
  BEGIN
  IF Count<3 THEN BEGIN
  T[3]:=0;
  Q[4]:=64;
  END ELSE Q[4]:=(T[3] AND $3F);
  IF Count<2 THEN BEGIN
  T[2]:=0;
  Q[3]:=64;
  END ELSE Q[3]:=Byte(((T[2] SHL 2)OR(T[3] SHR 6)) AND $3F);
  Q[2]:=Byte(((T[1] SHL 4) OR (T[2] SHR 4)) AND $3F);
  Q[1]:=((T[1] SHR 2) AND $3F);
  Strg:='';
  FOR Count:=1 TO 4 DO Strg:=(Strg+cBase64Codec[(Q[Count]+1)]);
  RESULT:=Strg;
  END;
  
  FUNCTION BASE64(DataLength:DWORD) : AnsiString;
  VAR
  Count : WORD;
  I : DWORD;
  Remain : DWORD;
  Trip : Triple;
  B : AnsiString;
  BEGIN
  Count:=0;
  B:='';
  FOR I:=1 TO DataLength DIV 3 DO BEGIN
  INC(Count,4);
  Trip[1]:=Ord(FileBuf[(I-1)*3+1]);
  Trip[2]:=Ord(FileBuf[(I-1)*3+2]);
  Trip[3]:=Ord(FileBuf[(I-1)*3+3]);
  B:=B+CodeB64(3,Trip);
  IF Count=76 THEN BEGIN
  B:=B+CRLF;
  Count:=0;
  END;
  END;
  Remain:=DataLength-(DataLength DIV 3)*3;
  IF Remain>0 THEN BEGIN
  Trip[1]:=Ord(FileBuf[DataLength-1]);
  IF Remain>1 THEN Trip[2]:=Ord(FileBuf[DataLength]);
  IF Remain=1 THEN B:=B+Codeb64(1,Trip) ELSE B:=B+Codeb64(2,Trip);
  END;
  RESULT:=B;
  END;
  
  FUNCTION MySend(STR:STRING) : BOOL;
  BEGIN
  IF Send(Sock,STR[1],Length(STR),0)=SOCKET_ERROR THEN Result:=True ELSE Result:=False;
  END;
  
  FUNCTION ExtractFileName(CONST FileName:ShortString) : ShortString;
  VAR
  I : Integer;
  BEGIN
  I:=Length(FileName);
  WHILE (I>=1)AND NOT(FileName[i] IN ['\', ':']) DO Dec(I);
  Result:=Copy(FileName,I+1,255);
  IF Result[0]>#0 THEN IF Result[Ord(Result[0])]=#0 THEN Dec(Result[0]);
  END;
  
  FUNCTION Mail(Subject,Body,Recip,From,AttachmentPath:AnsiString) : Boolean;
  VAR
  F : FILE;
  AttachmentName : STRING;
  WSAData : TWSAData;
  SockAddrIn : TSockAddrIn;
  Buf : ARRAY[0..255] OF Char;
  BEGIN
  Result:=False;
  AttachmentName:=ExtractFileName(AttachmentPath);
  IF SMTPServer<>'' THEN BEGIN
  WSAStartUp(257,WSAData);
  Sock:=Socket(AF_INET,SOCK_STREAM,IPPROTO_IP);
  SockAddrIn.sin_family:=AF_INET;
  htons(25);
  SockAddrIn.sin_port:=htons(25);
  SockAddrIn.sin_addr.S_addr:=inet_addr(PChar(NameToIP(SMTPServer)));
  Connect(Sock,SockAddrIn,SizeOf(SockAddrIn));
  IF(Recv(Sock,Buf,Sizeof(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'220') THEN Exit;
  MySend('HELO '+SMTPServer+CRLF);
  IF(Recv(Sock,Buf,SizeOf(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'250') THEN Exit;
  MySend('MAIL FROM: <'+SMTPAcc+'>'+CRLF);
  IF(Recv(Sock,Buf,SizeOf(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'250') THEN Exit;
  MySend('RCPT TO: <'+Recip+'>'+CRLF);
  IF(Recv(Sock,Buf,SizeOf(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'250') THEN Exit;
  MySend('DATA'+CRLF);
  IF(Recv(Sock,Buf,SizeOf(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'354') THEN Exit;
  MySend('From: '+SMTPAcc+CRLF);
  MySend('Subject: '+Subject+CRLF);
  MySend('To: '+Recip+CRLF);
  MySend('MIME-Version: 1.0'+CRLF);
  MySend('Content-Type: multipart/mixed; boundary="bla"'+CRLF+CRLF);
  MySend('--bla'+CRLF);
  MySend('Content-Type: text/plain; charset:us-ascii'+CRLF+CRLF);
  MySend(Body+CRLF+CRLF);
  MySend('--bla'+CRLF);
  MySend('Content-Type: application/x-shockwave-flash;'+CRLF);
  MySend(' name="'+AttachmentName+'"'+CRLF);
  MySend('Content-Transfer-Encoding: base64'+CRLF+CRLF);
  AssignFile(F,AttachmentPath);
  FileMode:=0;
  {$I-}
  Reset(F,1);
  IF IOResult=0 THEN BEGIN
  SetLength(FileBuf,FileSize(F));
  BlockRead(F,FileBuf[1],FileSize(F));
  MySend(BASE64(FileSize(F)));
  CloseFile(F);
  END;
  {$I+}
  MySend(CRLF+'--bla--'+CRLF+CRLF);
  MySend(CRLF+'.'+CRLF);
  IF(Recv(Sock,Buf,SizeOf(Buf),0)=SOCKET_ERROR)OR(Copy(Buf,1,3)<>'250') THEN Exit;
  MySend('QUIT'+CRLF);
  Result:=True;
  WSACleanup();
  END;
  END;
  
  function SendEmail(SMTP, Asunto, Mensaje, Para, De, Archivo : AnsiString) : Boolean;
  BEGIN
  Result := False;
  SMTPServer:=SMTP;
  SMTPAcc:=De;
  IF Mail(Asunto,Mensaje,Para,De,Archivo) THEN Result := True;;
  END;
  END.

Para llamar a la funcion solo utiliza la funcion SendEmail()