Importación de Contactos desde outlook

[hot1974]

Hola a todos los foreros, gracias por dedicarle un espacio a estas lineas,
Tengo la siguiente necesidad, espero alguno de ustedes me pueda ayudar, necesito realizar un importador de la base de datos de contactos de outlook, nada mas que no tengo ni la menor idea por donde empezar, quisiera si me podrian ayudar con que tipo de archivo es, como lo leo que componentes debo de usar si es necesario usar los de la paleta de server y como se utilizan.

Gracias mil a todos.

[marcoszorrilla]

He encontrado esto en Torrys, no he hecho ninguna prueba, si te sirve y funciona nos lo comunicas.

Código Delphi [-]
 unit ExtractEmailsFunc;
 
 interface
 
 uses
   Windows, SysUtils;
 
 procedure CheckEMail(FilePath: string);
 
 implementation
 
 var
   BufferSize: Integer;
 
 function VerifyFile(strFileName: string): Integer;
 var
   intErro: Integer;
   tsrFile: TSearchRec;
 begin
   intErro := FindFirst(strFileName, FaAnyFile, tsrFile);
   if intErro = 0 then Result := tsrFile.Size 
   else 
     Result := -1;
   FindClose(tsrFile);
 end;
 
 procedure CheckEMail(FilePath: string);
 var
   I: Integer;
   hFile: Integer;
   Buffer: PChar;
   StrEmail: string;
 begin
   hFile := FileOpen(FilePath, fmOpenRead);
   try
     if hFile = 0 then Exit;
     GetMem(Buffer, bufferSize + 1);
     ZeroMemory(Buffer, BufferSize + 1);
     try
       FileRead(hFile, Buffer^, BufferSize);
       I := 0;
       while I <= BufferSize - 1 do 
       begin
         StrEmail := '';
         if Buffer[i] = '<' then 
         begin
           Inc(I);
           while (Buffer[i] <> '@') and (I <= BufferSize) do 
           begin
             if (Buffer[i] = CHR(45)) or (Buffer[i] = CHR(46)) or
               (Buffer[i] = CHR(90)) or ((Buffer[i] > CHR(49)) and (Buffer[i] <= CHR(57)))
               or ((Buffer[i] >= CHR(65)) and (Buffer[i] <= CHR(90))) or
               ((Buffer[i] >= CHR(97)) and (Buffer[i] <= CHR(122))) then 
             begin
               StrEmail := StrEmail + Buffer[i];
             end 
             else 
             begin
               StrEmail := '';
               Break;
             end;
             Inc(I);
           end;
           if StrEmail <> '' then 
           begin
             StrEmail := StrEmail + '@';
             Inc(I);
             while (Buffer[i] <> '.') and (I <= BufferSize) do 
             begin
               if (Buffer[i] = CHR(45)) or (Buffer[i] = CHR(46)) or
                 (Buffer[i] = CHR(90)) or ((Buffer[i] >= CHR(49)) and (Buffer[i] <= CHR(57)))
                 or ((Buffer[i] >= CHR(65)) and (Buffer[i] <= CHR(90))) or
                 ((Buffer[i] >= CHR(97)) and (Buffer[i] <= CHR(122))) then 
               begin
                 StrEmail := StrEmail + Buffer[i];
               end 
               else 
               begin
                 StrEmail := '';
                 Break;
               end;
               Inc(I);
             end;
             if StrEmail <> '' then 
             begin
               StrEmail := StrEmail + '.';
               Inc(i);
               while (Buffer[i] <> '>') and (I <= BufferSize) do 
               begin
                 if (Buffer[i] = CHR(45)) or (Buffer[i] = CHR(46)) or
                   (Buffer[i] = CHR(90)) or ((Buffer[i] >= CHR(49)) and (Buffer[i] <= CHR(57)))
                   or ((Buffer[i] >= CHR(65)) and (Buffer[i] <= CHR(90))) or
                   ((Buffer[i] >= CHR(97)) and (Buffer[i] <= CHR(122))) then 
                 begin
                   StrEmail := StrEmail + Buffer[i];
                 end 
                 else 
                 begin
                   StrEmail := '';
                   Break;
                 end;
                 Inc(I);
               end;
               if StrEmail <> '' then 
               begin
                 WriteLn(StrEmail);
                 Inc(I);
               end;
             end;
           end;
         end 
         else 
           Inc(I);
       end;
     finally
       FreeMem(Buffer);
     end;
   finally
     FileClose(hFile);
   end;
 end;
 
 begin
   BufferSize := VerifyFile(ParamStr(1));
   if BufferSize <= 0 then Exit;
   CheckEMail(ParamStr(1));
 end.

Un Saludo.

[hot1974]

Gracias por tu respuesta marcos pero creo que no es lo que necesito ya que esta función extrae los correos electronicos, no la lista de contactos, gracias y seguimos buscando, espero mas ayuda.

[Casimiro Notevi]

desde el outlook puedes hacer una exportación, esto te crea un archivo simple de texto con los datos separados por 'punto y coma', luego haces una sencilla importación leyendo ese ficherito de texto.

[hot1974]

Gracias por tu sugerencia casimiro, de hecho asi lo he estado trabajando de forma temporal hasta no encontrar la solucion, pero como comento al inicio del post estoy desarrollando u software que tome los datos directamente de la lista de contactos del outlook de forma transparente sin que haga nada el usuario, gracias por las respuestas y seguimos buscando

[jcasassa]

Hola!

Busca aquí es la web ajpdsoft .

Creo que te servirá.

Joan

[hot1974]

Perfecto joan me funciono a las mil maravillas mil gracias .
Saludos
Alejandro

[hot1974]

Este es el codigo que use espero les sirva

private
{ Private declarations }
public
{ Public declarations }
end;

var
FrmImporta: TFrmImporta;
linea : string;
carpetasOutlook : TStringList;

const
carContactos = $0000000A; //Contactos

implementation

{$R *.dfm}
procedure cargarCarpeta(Folder: OleVariant);
var
i : Integer;
begin
for i := 1 to Folder.Count do
begin
carpetasOutlook.Add(Folder.Item[i].Name);
cargarCarpeta(Folder.Item[i].Folders);
end;
end;

procedure TFrmImporta.Button1Click(Sender: TObject);
var
MsOutlook, MapiName, MisContactos : variant;
num,dato,y : integer;
contactosTemp : TStringList;
begin
lInfoContactos.Caption := 'Conectado a Outlook...';
lInfoContactos.Refresh;
// txtContactos.Lines.Clear;
try
MsOutlook := CreateOleObject('Outlook.Application');
except
on err : exception do
begin
lInfoContactos.Caption := '';
lInfoContactos.Refresh;
MessageDlg ('No se ha podido acceder a Outlook. Se ha producido el siguiente error: ' +
chr(13) + chr(13) + err.Message, mtError, [mbok], 0);
Exit;
end;
end;
try
MapiName := MsOutlook.GetNameSpace('MAPI');
If MsOutlook.name = 'Outlook' Then
begin
MapiName.Logoff;
MapiName.Logon('','');
bpContactos.Visible := true;
bpContactos.Min := 0;
dato:=MapiName.folders('Carpetas personales').folders(txtNombreContactos.text).items.count;
bpContactos.Max:=Dato-1;
for y := 1 to (dato-1) do
begin
bpContactos.Position := y;
bpContactos.Refresh;
lInfoContactos.Caption := 'Obteniendo contacto ' + inttostr(y) +
' de ' + inttostr(dato-1);
lInfoContactos.Refresh;
MisContactos := MapiName.folders('Carpetas personales').folders('Contactos').items(y);
try
linea := '';
Table1.Append;
Table1APaterno.Value := miscontactos.lastname;
Table1AMaterno.Value := miscontactos.middlename;
Table1Nombre.Value := MisContactos.firstname;
Table1Trabajo.Value := MisContactos.CompanyName;
//validacion de datos de cliente
if Table1Trabajo.Value<>'' then
begin
Table1Trabajo.Value;
Table3.IndexFieldNames:='descliente';
if not Table3.FindKey([Table1Trabajo.Value]) then
begin
Table3.IndexFieldNames:='cvecliente';
Table3.Last;
num:=Table3Cvecliente.AsInteger+1;
Table3.Append;
Table3Cvecliente.AsString:=inttostr(num);
Table3Descliente.Value:=MisContactos.CompanyName;;
Table3Dircliente.Value:=MisContactos.BusinessAddressStreet;
Table3Ciudad.Value :=MisContactos.BusinessAddressCity;
Table3Pais0.Value :=MisContactos.BusinessAddressCountry;
Table3CPcliente.Value :=MisContactos.BusinessAddressPostalCode;
Table3Estado1.Value :=MisContactos.BusinessAddressState;
end;
end;
Table1CalleYNumero.Value := miscontactos.HomeAddressStreet;
Table1Ciudad.Value := MisContactos.HomeAddressCity;
Table1Pais.Value := MisContactos.HomeAddressCountry;
Table1CodigoPostal.Value := MisContactos.HomeAddressPostalCode;
Table1Estado.Value := MisContactos.HomeAddressState;
Table1Contacto.Value := MisContactos.Title;
Table1Puesto.Value := MisContactos.department;
Table1.Post;
linea:=MisContactos.Email1Address;
if linea <> '' then
begin
Table2.Append;
Table2TipoDato.Value:='email';
Table2Dato.Value :=linea;
Table2.Post;
end;
linea:=MisContactos.BusinessTelephoneNumber;
if linea <> '' then
begin
Table2.Append;
Table2TipoDato.Value:='Telefono Oficina';
Table2Dato.Value :=linea;
Table2.Post;
end;
linea:=MisContactos.HomeTelephoneNumber;
if linea <> '' then
begin
Table2.Append;
Table2TipoDato.Value:='Telefono Casa';
Table2Dato.Value :=linea;
Table2.Post;
end;
linea:=MisContactos.MobileTelephoneNumber;
if linea <> '' then
begin
Table2.Append;
Table2TipoDato.Value:='Celular';
Table2Dato.Value :=linea;
Table2.Post;
end;
linea:=MisContactos.PersonalHomePage;
if linea <> '' then
begin
Table2.Append;
Table2TipoDato.Value:='Pagina Web';
Table2Dato.Value :=linea;
Table2.Post;
end;
except
end;
end;
ShowMessage('importacion Terminada');
close;

end
else
MessageDlg ('No se ha podido acceder a Outlook.', mtWarning, [mbok], 0);
except
on err : exception do
begin
lInfoContactos.Caption := '';
bpContactos.Visible := false;
MessageDlg ('No se ha podido acceder a Outlook. Se ha producido el siguiente error: ' +
chr(13) + chr(13) + err.Message, mtError, [mbok], 0);
MsOutlook := null;
end;
end;
MsOutlook := null;
end;

procedure TFrmImporta.FormCreate(Sender: TObject);
var
outlook : OLEVariant;
NameSpace : variant;
begin
Table1.Open;
Table2.Open;
Table3.Open;
try
//mostramos en el desplegable las carpetas de outlook
outlook := CreateOleObject('Outlook.Application');
NameSpace := outlook.GetNameSpace('MAPI');
carpetasOutlook := TStringList.Create;
cargarCarpeta(NameSpace.Folders);
txtNombreContactos.Clear;
txtNombreContactos.Items.AddStrings(carpetasOutlook);
//asignamos la carpeta de "contactos" por defecto
txtNombreContactos.Text := NameSpace.GetDefaultFolder(carContactos);
except
on err : exception do
begin
outlook := UnAssigned;
MessageDlg('No se ha podido acceder a Outlook con el perfil por defecto, compruebe los datos del perfil: ' +
chr(13) + chr(13) + err.message, mtInformation, [mbok], 0);
end;
end;
end;

end.