[s2004]

Код:

procedure TForm1.AddUrl1Click(Sender: TObject);
begin
Caption := AddToFavorites(IEAddress1.Text, '', 'Delphi');
end;
unit DlgAddToFavourites;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons, ShlObj;
 
type
  TfAddToFavorites = class(TForm)
    GroupBox1: TGroupBox;
    eUrl: TEdit;
    GroupBox2: TGroupBox;
    GroupBox3: TGroupBox;
    eName: TEdit;
    cbFolder: TComboBox;
    BitBtn1: TBitBtn;
    bOk: TBitBtn;
    bCancel: TBitBtn;
    procedure cbFolderDrawItem(Control: TWinControl; Index: Integer;
      r: TRect; State: TOwnerDrawState);
    procedure bOkClick(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
  private
    fFileName: string;
    function GetFolder: string;
    function GetUName: string;
    function GetUrl: string;
    procedure SetFolder(const Value: string);
    procedure SetUName(const Value: string);
    procedure SetUrl(const Value: string);
    procedure RescanFolders;
    function GetFavourites: string;
  public
    function Execute(AUrl: string; AName: string = ''; AFolder: string = ''): Boolean;
    property FovouritesFolder: string read GetFavourites;
    constructor Create(AOwner: TComponent); override;
  published
    property URL: string read GetUrl write SetUrl;
    property UName: string read GetUName write SetUName;
    property Folder: string read GetFolder write SetFolder;
    property FileName: string read fFileName write fFileName;
  end;
 
function AddToFavorites(AUrl, AName, AFolder: string): string;
 
implementation
 
{$R *.dfm}
 
{ TfAddToFavorites }
 
constructor TfAddToFavorites.Create(AOwner: TComponent);
begin
  inherited;
  RescanFolders;
end;
 
function TfAddToFavorites.Execute(AUrl, AName, AFolder: string): Boolean;
begin
  UName := AName;
  Url := AUrl;
  if AFolder <> '' then
    AFolder := ExtractFileName(GetFavourites) + '\' + AFolder;
  cbFolder.ItemIndex := cbFolder.Items.IndexOf(AFolder);
  if (cbFolder.ItemIndex = -1) then cbFolder.ItemIndex := 0;
  Result := ShowModal = mrOk;
end;
 
function TfAddToFavorites.GetFavourites: string;
var s:  string;
begin
  SetLength(s, MAX_PATH);
  if not SHGetSpecialFolderPath(0, PChar(s), CSIDL_FAVORITES, true)
  then s := '';
  result := PChar(s);
end;
 
function TfAddToFavorites.GetFolder: string;
begin
  Result := cbFolder.Text;
end;
 
function TfAddToFavorites.GetUName: string;
begin
  Result := eName.Text;
end;
 
function TfAddToFavorites.GetUrl: string;
begin
  Result := eUrl.Text;
end;
 
procedure ScanFolder(path: string; sl: TStrings; pref: string);
var
  sr: TSearchRec;
begin
  path := path + '\';
  if FindFirst(path + '*.*', faDirectory, sr) = 0 then
  begin
    repeat
      if ((sr.Attr and faDirectory) = faDirectory) then
      if (sr.Name <> '.') and (sr.Name <> '..') then
      begin
        sl.Add(pref + sr.Name);
        ScanFolder(path + sr.Name, sl, pref + '\' + sr.Name);
      end;
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
end;
 
procedure TfAddToFavorites.RescanFolders;
var
  sl: TStrings;
  p:  string;
begin
  p := GetFavourites;
  sl := cbFolder.Items;
  sl.Add(ExtractFileName(p));
  ScanFolder(p, sl, ExtractFileName(p) + '\');
end;
 
procedure TfAddToFavorites.SetFolder(const Value: string);
begin
  cbFolder.Text := Value;
end;
 
procedure TfAddToFavorites.SetUName(const Value: string);
begin
  eName.Text := Value;
end;
 
procedure TfAddToFavorites.SetUrl(const Value: string);
begin
  eUrl.Text := Value;
end;
 
function AddToFavorites(AUrl, AName, AFolder: string): string;
var f: TfAddToFavorites;
begin
  Application.CreateForm(TfAddToFavorites, f);
  if f.Execute(AUrl, AName, AFolder) then Result := f.FileName
  else Result := '';
  f.Free;
end;
 
procedure TfAddToFavorites.cbFolderDrawItem(Control: TWinControl;
  Index: Integer; r: TRect; State: TOwnerDrawState);
var
  i,o,l,d: integer;
  s,n: string;
  cb: TComboBox;
begin
  cb := TComboBox(Control);
  s := cb.Items[Index];
  n := ExtractFileName(s);
  o := 0;
  for i := 1 to Length(s) do if s[i] = '\' then Inc(o);
  with cb.Canvas do
  begin
    if odHotLight    in State then cb.Brush.Color := clHighlight
    else cb.Brush.Color := clWindow;
    cb.Canvas.FillRect(Rect(0, r.Top, cb.Width, r.Bottom));
    l := r.Left + o * 10; d := r.Top + (r.Bottom - r.Top) div 2;
    Polyline([Point(l-1, d), Point(l-5, d), Point(l-5, r.Top), Point(l-5, r.Bottom)]);
    cb.Canvas.TextOut(l, r.Top, n);
  end;
end;
 
procedure TfAddToFavorites.bOkClick(Sender: TObject);
var
  f: string;
  sl: TStringList;
begin
  f := ExtractFilePath(GetFavourites) + Folder;
  ForceDirectories(f);
  sl := TStringList.Create;
  sl.Add('[InternetShortcut]');
  sl.Add('URL=' + url);
  f := f + '\' + UName + '.url';
  try
    sl.SaveToFile(f);
  finally
    sl.Free;
  end;
  Close;
end;
 
procedure TfAddToFavorites.BitBtn1Click(Sender: TObject);
var
  f: TForm;
  e: TEdit;
  b: TBitBtn;
  s: string;
begin
  f := TForm.Create(nil);
  f.Width := 300;
  f.Caption := 'Add New Folder';
  f.Position := poScreenCenter;
  e := TEdit.Create(f);
  e.Parent := f;
  f.ClientHeight := e.Height;
  e.Align := alTop;
  b := TBitBtn.Create(f);
  b.Top := e.BoundsRect.Bottom + 4;
  b.Left := 8;
  b.Parent := f;
  b.Kind := bkOK;
  b := TBitBtn.Create(f);
  b.Top := e.BoundsRect.Bottom + 4;
  b.Parent := f;
  b.Kind := bkCancel;
  b.Left := f.ClientWidth - b.Width - 8;
  b.Anchors := [akTop, akRight];
  f.ClientHeight := b.BoundsRect.Bottom + 4;
  if f.ShowModal = mrOk then
  begin
    if e.Text = '' then Exit;
    s := cbFolder.Text + '\' + e.Text;
    cbFolder.Items.Insert(cbFolder.ItemIndex + 1, s);
    cbFolder.ItemIndex := cbFolder.ItemIndex + 1;
  end;
end;
 
end.

английский выводится правильно, русский кокарябины