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.


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í (http://www.ajpdsoft.com/modules.php?name=Downloads&d_op=search&query=) es la web ajpdsoft (http://www.ajpdsoft.com) .

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.

:p