Создать новый Outlook Contact?

Материал из DRKB


uses
  ComObj, Variants, SysUtils;

type
  TContact = record
    LastName: string;
    FirstName : string;
    Company : string;
    // ###  Further properties. See MSDN
  end;


//------------------------------------------------------------------------------
{:Add outlook contact

@param ContactFolderPath The contact path. E.g.: '' for default contact folder,
  'SubFolder\Sub2\Test' for subfolders
@param Contact The contact informations.
@author 19.09.2003 Michael Klemm}
//------------------------------------------------------------------------------
procedure OutlookAddContact(ContactFolderPath: string; Contact: TContact);
const
  olFolderContacts = $0000000A;
var
  Outlook: OleVariant;
  NameSpace: OleVariant;
  ContactsRoot: OleVariant;
  ContactsFolder: OleVariant;
  OutlookContact: OleVariant;
  SubFolderName: string;
  Position: Integer;
  Found: Boolean;
  Counter: Integer;
  TestContactFolder: OleVariant;
begin
  // Connect to outlook
  Outlook := CreateOleObject('Outlook.Application');
  // Get name space
  NameSpace := Outlook.GetNameSpace('MAPI');
  // Get root contacts folder
  ContactsRoot := NameSpace.GetDefaultFolder(olFolderContacts);
  // Iterate to subfolder
  ContactsFolder := ContactsRoot;
  while ContactFolderPath <> '' do
  begin
    // Extract next subfolder
    Position := Pos('\', ContactFolderPath);
    if Position > 0 then
    begin
      SubFolderName := Copy(ContactFolderPath, 1, Position - 1);
      ContactFolderPath := Copy(ContactFolderPath, Position + 1, Length(ContactFolderPath));
    end
    else
    begin
      SubFolderName := ContactFolderPath;
      ContactFolderPath := '';
    end;
    if SubFolderName = '' then
      Break;
    // Search subfolder
    Found := False;
    for Counter := 1 to ContactsFolder.Folders.Count do
    begin
      TestContactFolder := ContactsRoot.Folders.Item(Counter);
      if LowerCase(TestContactFolder.Name) = LowerCase(SubFolderName) then
      begin
        ContactsFolder := TestContactFolder;
        Found := True;
        Break;
      end;
    end;
    // If not found create
    if not Found then
      ContactsFolder := ContactsFolder.Folders.Add(SubFolderName);
  end;
  // Create contact item
  OutlookContact := ContactsFolder.Items.Add;
  // Fill contact information
  OutlookContact.FirstName := Contact.FirstName;
  OutlookContact.LastName := Contact.LastName;
  OutlookContact.CompanyName := Contact.Company;

  // ### Further properties

  // Save contact
  OutlookContact.Save;
  // Disconnect from outlook
  Outlook := Unassigned;
end;


Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04444