newfldrf.~pas

是一个delphi的流程制作软件

unit NewFldrF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TCreateFolderFrom = class(TForm)
    CreateBtn: TButton;
    procedure CreateBtnClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  CreateFolderFrom: TCreateFolderFrom;

implementation

uses ComObj;

{$R *.DFM}

procedure TCreateFolderFrom.CreateBtnClick(Sender: TObject);
const
  olFolderContacts = 10;
  olContactItem = 2;
var
  OutlookApp,
  Mapi,
  NewContact,
  BorlandContacts,
  ContactItems,
  CurrentContact:       Variant;
  I,
  ToRemove:             Integer;
begin
  {Get the Outlook Application object.}
  OutlookApp := CreateOleObject('Outlook.Application');
  {Get the MAPI NameSpace object.}
  Mapi := OutlookApp.GetNameSpace('MAPI');
  {Get the Items collection from the Contacts folder.
   Note that if you do not do this FindNext will not work.}
  ContactItems := Mapi.Folders('Personal Folders').Folders('Contacts').Items;
  {Remove the test folder.}
  ToRemove := 0;
  for I := 1 to Mapi.Folders('Personal Folders').Folders.Count do
    if Mapi.Folders('Personal Folders').Folders(I).Name = 'Borland Contacts' then
    begin
      ToRemove := I;
      Break;
    end; //if
  if ToRemove <> 0 then
    Mapi.Folders('Personal Folders').Folders.Remove(ToRemove);
  {Create a new folder.}
  Mapi.Folders('Personal Folders').Folders.Add('Borland Contacts',
    olFolderContacts);
  BorlandContacts := Mapi.Folders('Personal Folders').Folders('Borland Contacts');
  {Load Contacts into new folder.}
  CurrentContact := ContactItems.Find('[CompanyName] = ' +
                      QuotedStr('Borland International'));
  while not VarIsEmpty(CurrentContact) do
  begin
    {Add a new item to the folder.}
    NewContact := BorlandContacts.Items.Add;
    {Assign values to the fields in the item record.}
    NewContact.FullName := 'John Doe';
    NewContact.LastName := CurrentContact.LastName;
    NewContact.FirstName := CurrentContact.FirstName;
    NewContact.CompanyName := CurrentContact.CompanyName;
    NewContact.BusinessAddressStreet := CurrentContact.BusinessAddressStreet;
    NewContact.BusinessAddressPostOfficeBox :=
      CurrentContact.BusinessAddressPostOfficeBox;
    NewContact.BusinessAddressCity := CurrentContact.BusinessAddressCity;
    NewContact.BusinessAddressState := CurrentContact.BusinessAddressState;
    NewContact.BusinessAddressPostalCode :=
      CurrentContact.BusinessAddressPostalCode;
    NewContact.BusinessTelephoneNumber :=
      CurrentContact.BusinessTelephoneNumber;
    {Save the new record.}
    NewContact.Save;
    {Find the next record in the Contacts folder.}
    CurrentContact := ContactItems.FindNext;
  end; //while
  {Close Outlook.}
  OutlookApp := Unassigned;
end;

end.