| Код |
procedure TForm1.AddUrl1Click(Sender: TObject);
begin
Caption := AddToFavorites(IEAddress1.Text, '', 'Delphi');
end;
|
в uses файл DlgAddToFavourites.pas
| Код |
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.
|
английский шрифт выводится нормально, но если русский то какарябины. |