uoutlooksync.pas

来自「FMA is a free1 powerful phone editing to」· PAS 代码 · 共 582 行 · 第 1/2 页

unit uOutlookSync;

{
*******************************************************************************
* Descriptions: Outlook Contact Sync Unit
* $Source: /cvsroot/fma/fma/uOutlookSync.pas,v $
* $Locker:  $
*
* Todo:
*
* Change Log:
* $Log: uOutlookSync.pas,v $
*
}

interface

uses
  uContactSync, Outlook8, Classes, TntClasses;

type
  TOutlookContact = class(TContact)
  private
    FOutlookContact: ContactItem;
  protected
    function Exists: Boolean; override;
  public
    property OutlookContact: ContactItem read FOutlookContact write FOutlookContact;
  end;

  TOutlookContactFieldMapper = class(TContactFieldMapper)
  private
    FOutlookContact: ContactItem;
  protected
    function GetVariant(Field: String): Variant; override;
    procedure SetVariant(Field: String; const Value: Variant); override;
  public
    constructor Create;

    property OutlookContact: ContactItem read FOutlookContact write FOutlookContact;
  end;

  TOutlookContactSource = class(TContactSource)
  private
    Outlook: OutlookApplication;
    NmSpace: NameSpace;
    FCategories: TStrings;
    FFolders: TStrings;
    FNewContactsFolder: String;
    FNewContactsFolderFolder: MAPIFolder;
    function InCategories(OutlookContact: ContactItem): Boolean;
    procedure SetCategories(const Value: TStrings);
    procedure SetFolders(const Value: TStrings);
    procedure SetNewContactsFolder(const Value: String);
  protected
    function GetName: String; override;
    function GetOutlookCategories: String;
    function ExtractQuotedStr(Str: String): String;
    procedure Read(Contact: TOutlookContact; OutlookContact: ContactItem);
    procedure Write(Contact: TContact; OutlookContact: ContactItem);
  public
    constructor Create;
    destructor Destroy; override;

    function New: TContact; override;
    function Add(Value: TContact): TContact; override;
    procedure Update(Contact, Value: TContact); override;
    procedure Delete(Contact: TContact); override;

    procedure Load; override;

    property Categories: TStrings read FCategories write SetCategories;
    property Folders: TStrings read FFolders write SetFolders;
    property NewContactsFolder: String read FNewContactsFolder write SetNewContactsFolder;
  end;

implementation

uses
  gnugettext, gnugettexthelpers, uLogger, uConnprogress, uThreadSafe,
  SysUtils, TntSysUtils, Forms, TntForms, ActiveX, Windows;

// Innerfuse Pascal Script III function
var
  DispPropertyPut: Integer = DISPID_PROPERTYPUT;

function IDispatchInvoke(Self: IDispatch; PropertySet: Boolean; const Name: String; const Par: array of Variant): Variant;
var
  Param: Word;
  i, ArgErr: Longint;
  DispatchId: Longint;
  DispParam: TDispParams;
  ExceptInfo: TExcepInfo;
  aName: PWideChar;
  WSFreeList: TList;
begin
  FillChar(ExceptInfo, SizeOf(ExceptInfo), 0);
  aName := StringToOleStr(Name);
  try
    if Self = nil then
      raise Exception.Create('NIL Interface Exception');
    if Self.GetIDsOfNames(GUID_NULL, @aName, 1, LOCALE_SYSTEM_DEFAULT, @DispatchId) <> S_OK then
      raise Exception.Create('Unknown Method');
  finally
    SysFreeString(aName);
  end;

  DispParam.cNamedArgs := 0;
  DispParam.rgdispidNamedArgs := nil;
  DispParam.cArgs := (High(Par) + 1);

  if PropertySet then begin
    Param := DISPATCH_PROPERTYPUT;
    DispParam.cNamedArgs := 1;
    DispParam.rgdispidNamedArgs := @DispPropertyPut;
  end
  else
    Param := DISPATCH_METHOD or DISPATCH_PROPERTYGET;

  WSFreeList := TList.Create;
  try
    GetMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
    FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * (High(Par) + 1), 0);
    try
      for i := 0 to High(Par) do begin
        if PVarData(@Par[i]).VType = varString then begin
          DispParam.rgvarg[i].vt := VT_BSTR;
          DispParam.rgvarg[i].bstrVal := StringToOleStr(Par[i]);
          WSFreeList.Add(DispParam.rgvarg[i].bstrVal);
        end
        else begin
          DispParam.rgvarg[i].vt := VT_VARIANT or VT_BYREF;
          New(POleVariant(DispParam.rgvarg[i].pvarVal));
          POleVariant(DispParam.rgvarg[i].pvarVal)^ := Par[i];
        end;
      end;
      i :=Self.Invoke(DispatchId, GUID_NULL, LOCALE_SYSTEM_DEFAULT, Param, DispParam, @Result, @ExceptInfo, @ArgErr);
      if not Succeeded(i) then begin
        if i = DISP_E_EXCEPTION then
          raise Exception.Create(ExceptInfo.bstrSource+': '+ExceptInfo.bstrDescription)
        else
          raise Exception.Create(SysErrorMessage(i));
      end;
    finally
      for i := 0 to High(Par) do begin
        if DispParam.rgvarg[i].vt = (VT_VARIANT or VT_BYREF) then begin
          if POleVariant(DispParam.rgvarg[i].pvarVal) <> nil then
            Dispose(POleVariant(DispParam.rgvarg[i].pvarVal));
        end;
      end;
      FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * (High(Par) + 1));
    end;
  finally
    for i := WSFreeList.Count -1 downto 0 do
      SysFreeString(WSFreeList[i]);
    WSFreeList.Free;
  end;
end;

{ TOutlookContactSource }

function TOutlookContactSource.GetOutlookCategories: String;
var I: Integer;
begin
  Result := '';
  for I := 0 to Categories.Count - 1 do
    if Trim(Categories[I]) <> '' then begin
      if Result <> '' then Result := Result + '; ';
      Result := Result + Categories[I];
    end;
end;

function TOutlookContactSource.Add(Value: TContact): TContact;
var
  Contact: TOutlookContact;
begin
  Contact := New as TOutlookContact;
  Contact.Clone(Value);
  Contact.LinkedContact := Value;
  Value.LinkedContact := Contact;
  Contacts.Add(Contact);

  if Assigned(FNewContactsFolderFolder) then
    Contact.OutlookContact := FNewContactsFolderFolder.Items.Add(olContactItem) as ContactItem
  else
    Contact.OutlookContact := Outlook.CreateItem(olContactItem) as ContactItem;
  Contact.OutlookContact.Categories := GetOutlookCategories;
  Write(Contact, Contact.OutlookContact);
  Contact.ID := Contact.OutlookContact.EntryID;

  Result := Contact;
end;

constructor TOutlookContactSource.Create;
begin
  inherited;
  FCategories := TStringList.Create;
  FCategories.Delimiter := ';';
  FFolders := TStringList.Create;

  FieldMapper := TOutlookContactFieldMapper.Create;

  Outlook := CoOutlookApplication.Create;
  NmSpace := Outlook.GetNamespace('MAPI'); // do not localize
//  NmSpace.Logon('', '', False, False);
end;

procedure TOutlookContactSource.Delete(Contact: TContact);
begin
  with Contact as TOutlookContact do begin
    OutlookContact.Delete;

    OutlookContact := nil;
  end;
end;

destructor TOutlookContactSource.Destroy;
begin
  FieldMapper.Free;
  FCategories.Free;
  FFolders.Free;
  
  inherited;
end;

function TOutlookContactSource.ExtractQuotedStr(Str: String): String;
var P: PChar;
begin
  P := PChar(Str);
  Result := AnsiExtractQuotedStr(P, '"');
  if Result = '' then Result := Str;
end;

function TOutlookContactSource.GetName: String;
begin
  Result := 'Outlook'; //TODO -cl10n: localize?
end;

function TOutlookContactSource.InCategories(OutlookContact: ContactItem): Boolean;
var Cats, Cat: String;
    P: Integer;
begin
  if Categories.Count > 0 then begin
    Result := False;
    Cats := OutlookContact.Categories;
    while Cats <> '' do begin
      P := Pos(';', Cats);
      if P = 0 then  // A propper Outlook Version check would be better
        P := Pos(',', Cats);  // Outlook 2003 uses , instead of ;
      if P = 0 then
        P := Length(Cats) + 1;

      Cat := Trim(Copy(Cats, 1, P - 1));
      System.Delete(Cats, 1, P);

      Result := Categories.IndexOf(Cat) <> - 1;
      if Result then Break;
    end;
  end
  else
    Result := True;
end;

procedure TOutlookContactSource.Load;
var j: Integer;
    Folder: MAPIFolder;
    dlg: TfrmConnect;
  procedure LoadFolder(Folder: MAPIFolder);
  var I: Integer;
      OutlookContact: ContactItem;
      Contact: TOutlookContact;
      Count, CountNew, CountFiltered: Integer;
  begin
    Count := 0;
    CountNew := 0;
    CountFiltered := 0;
    //Folder.Items.IncludeRecurrences := False;
    if Assigned(dlg) then dlg.Initialize(Folder.Items.Count,
      WideFormat(_('Loading external contact folders')+sLineBreak+'(%s %s)',[Name,Folder.Name]));   
    for I := 1 to Folder.Items.Count do begin
      if Assigned(dlg) then dlg.IncProgress(1);
      if Supports(Folder.Items.Item(I), ContactItem, OutlookContact) then begin
        if InCategories(OutlookContact) then begin
          Contact := Contacts.FindByID(OutlookContact.EntryID) as TOutlookContact;

          if Assigned(Contact) then begin
            Contact.OutlookContact := OutlookContact;
          end
          else begin
            Contact := New as TOutlookContact;
            Contact.ID := OutlookContact.EntryID;