Importación de Contactos desde outlook

[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.